I am trying to insert a new row into a named range. The user selects a "category" from a combo box e.g., Cool Drinks, Beer and Cider, Bitters etc... and then the contents of that category populate another combo box.
I have named the ranges of all of the Categories and would like them to populate the second combo box. I have a code which works by itself:
Dim rng As Range
Dim DailySales As Worksheet
Set DailySales = Worksheets("Daily Sales")
Set rng = DailySales.Range("CoolDrinksDailySales")
For Each rng In DailySales.Range("CoolDrinksDailySales")
Me.CmboName.AddItem rng.Value
Next rng
However, whenever I try to use that in a Select Case, it doesn't work.
Dim rng As Range
Dim DailySales As Worksheet
Set DailySales = Worksheets("Daily Sales")
Select Case Me.CmboType.Value
Case "Cool Drinks"
Set rng = DailySales.Range("CoolDrinksDailySales")
For Each rng In DailySales.Range("CoolDrinksDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Beer and Cider"
Set rng = DailySales.Range("BeerCiderDailySales")
For Each rng In DailySales.Range("BeerCiderDailySales")
Me.CmboName.AddItem rng.Value
Next rng
End Select
Does anybody have any ideas?
Here is the complete code:
Option Explicit
Private Sub UserForm_Initialize()
'InitializeTypeCombo
Dim Types() As String
Types = Split("Cool Drinks,Beer and
Cider,Bitters,Brandy,Whiskey,Rum,Spirits,Sherry,White Wine,Red Wine",
",")
Dim i As Integer
For i = LBound(Types) To UBound(Types)
Me.CmboType.AddItem Types(i)
Next
'InitializeNameCombo
Dim rng As Range
Dim DailySales As Worksheet
Set DailySales = Worksheets("Daily Sales")
Select Case Me.CmboType.Value
Case "Cool Drinks"
Set rng = DailySales.Range("CoolDrinksDailySales")
For Each rng In DailySales.Range("CoolDrinksDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Beer and Cider"
Set rng = DailySales.Range("BeerCiderDailySales")
For Each rng In DailySales.Range("BeerCiderDailySales")
Me.CmboName.AddItem rng.Value
Next rng
End Select
End Sub
Private Sub CmdExit_Click()
Unload Me
End Sub
Private Sub CmdEnter_Click()
Dim rng As Range
'Store Date Index
Dim colArray(32) As Integer
'Store Item Index
Dim rowArray(150) As Integer
'Store first value for Find and FindNext
Dim FirstAddress As String
Dim i As Integer
Dim j As Integer
i = 0
j = 0
With Range("B6:AD6")
Set rng = .Find(TxtDate.Value, LookIn:=xlValues)
If Not rng Is Nothing Then
FirstAddress = rng.Address
Do
Set rng = .FindNext(rng)
colArray(i) = rng.Column
i = i + 1
Loop While Not rng Is Nothing And rng.Address <> FirstAddress
End If
End With
With Range("A7:A150")
Set rng = .Find(CmboName.Value, LookIn:=xlValues)
If Not rng Is Nothing Then
FirstAddress = rng.Address
Do
Set rng = .FindNext(rng)
rowArray(j) = rng.Row
j = j + 1
Loop While Not rng Is Nothing And rng.Address <> FirstAddress
End If
End With
Dim c As Integer
Dim r As Integer
For c = 0 To i - 1
For r = 0 To j - 1
Cells(rowArray(r), colArray(c)).Value = TxtNoSold.Value
Next r
Next c
Unload Me
End Sub
The solution was simply moving the Select Case into the Combobox_Change event. As Dick Kusleika said, the value of the combobox was nothing at runtime. Here is the correct code to accomplish what I was trying to do.
Option Explicit
Private Sub Userform_Initialize()
'Populate cmboTypes
Dim Types() As String
Types = Split("Cool Drinks,Beer and _
Cider,Bitters,Brandy,Whiskey,Rum,Spirits,Sherry,White Wine,_
Red Wine", ",")
'Loop through the values populated in the split function above, and add
'each item to the combobox
Dim i As Integer
For i = LBound(Types) To UBound(Types)
Me.CmboType.AddItem Types(i)
Next
End Sub
Sub CmboType_Change()
Dim rng As Range
Dim DailySales As Worksheet
'Populate CmboName with named dynamic ranges of "Types"
Set DailySales = Worksheets("Daily Sales")
Select Case Me.CmboType.Value
Case "Cool Drinks"
Set rng = DailySales.Range("CoolDrinksDailySales")
For Each rng In DailySales.Range("CoolDrinksDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Beer and Cider"
CmboName.Clear
Set rng = DailySales.Range("BeerCiderDailySales")
For Each rng In DailySales.Range("BeerCiderDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Bitters"
CmboName.Clear
Set rng = DailySales.Range("BittersDailySales")
For Each rng In DailySales.Range("BittersDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Brandy"
CmboName.Clear
Set rng = DailySales.Range("BrandyDailySales")
For Each rng In DailySales.Range("BrandyDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Whiskey"
CmboName.Clear
Set rng = DailySales.Range("WhiskeyDailySales")
For Each rng In DailySales.Range("WhiskeyDailySales")
Me.CmboName.AddItem rng.Value
Next rng
End Select
End Sub
Related
My code tries to do this and paste just below the last row
Sub btnFind_Click()
Dim strLastRow As String
Dim rngC As Range
Dim strToFind As String, FirstAddress As String
Dim wSht As Worksheet
Dim rngtest As String
Application.ScreenUpdating = False
Set wSht = Worksheets("NewS")
strToFind = InputBox("Enter the value to find")
With ActiveSheet.Range("A1:A121")
Set rngC = .Find(what:=strToFind, LookAt:=xlPart)
If Not rngC Is Nothing Then
FirstAddress = rngC.Address
Do
strLastRow = Worksheets("NewS").Range("A" & Rows.Count).End(xlUp).Row + 1
rngC.EntireRow.Copy wSht.Cells(strLastRow, 1)
Set rngC = .FindNext(rngC)
Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress
End If
End With
MsgBox ("Finished")
End Sub
The results are pasted just below the last row of the active sheet
but I want the results to be pasted at column N3 as the start and also I dont want the actual string to be pasted (only the remaining column values in that row).
like the below image where I selected Value 2 as string.
Try this:
Sub btnFind_Click()
Dim rngC As Range, rngDest As Range
Dim strToFind As String, FirstAddress As String
Dim wSht As Worksheet
Dim rngtest As String
Application.ScreenUpdating = False
Set wSht = Worksheets("NewS")
strToFind = InputBox("Enter the value to find")
Set rngDest = wSht.Range("N3") 'start pasting here
With wSht.Range("A1:A121")
Set rngC = .Find(what:=strToFind, LookAt:=xlPart)
If Not rngC Is Nothing Then
FirstAddress = rngC.Address
Do
rngC.Offset(0, 1).Resize(1, 10).Copy rngDest 'move one cell right and copy 10 cols
Set rngDest = rngDest.Offset(1, 0) 'next destination row
Set rngC = .FindNext(rngC)
Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress
End If
End With
MsgBox "Finished"
End Sub
Looking for a simple loop through the range (say column A range("A5:A15")) if there is a blank cell within that range I need the entire row/rows associated with the blank cell/cells to be hidden.
I was thinking of something like this to accommodate various ranges but get "type Mismatch" error. Any reasons why
Sub test()
Dim rng As Range, cell As Variant, ar As Variant
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range
Dim MyArray(1 To 4) As Range
With ThisWorkbook.Worksheets("sheet1")
'Set MyArray = rng
Set MyArray(1) = Range("O8:O17")
Set MyArray(2) = Range("O55:O64")
Set MyArray(3) = Range("G37:G46")
Set MyArray(4) = Range("G89:G98")
'ar = Array(Rng1, Rng2, Rng3, Rng4)
'Set rng = .Range("O8:O17")
For Each cell In MyArray
If Len(cell.Value) < 1 Then
cell.EntireRow.Hidden = True
End If
Next cell
End With
End Sub
?
Something Like this:
You can put it in a subject:
For Each cell In Range("A5:A15")
If Len(cell.Value) < 1 Then
cell.EntireRow.Hidden = True
End If
Next
For Each cell In Range("A40:A55")
If Len(cell.Value) < 1 Then
cell.EntireRow.Hidden = True
End If
Next
New Answer :
Dim rng As Range, cell As Variant, ar As Variant
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range
Dim MyArray(1 To 4) As Range
With ThisWorkbook.Worksheets("sheet1")
'Set MyArray = rng
Set MyArray(1) = Range("O8:O17")
Set MyArray(2) = Range("O55:O64")
Set MyArray(3) = Range("G37:G46")
Set MyArray(4) = Range("G89:G98")
'ar = Array(Rng1, Rng2, Rng3, Rng4)
'Set rng = .Range("O8:O17")
Dim i As Integer
For i = LBound(MyArray) To UBound(MyArray)
For Each cell In MyArray(i)
If Len(cell.Value) < 1 Then
cell.EntireRow.Hidden = True
End If
Next
Next
End With
Try:
Option Explicit
Sub test()
Dim rng As Range, cell As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng = .Range("A5:A15")
For Each cell In rng
If cell.Value = "" Then
.Rows(cell.Row).EntireRow.Hidden = True
End If
Next cell
End With
End Sub
This takes full advantage of the Excel VBA model. I'm guessing it's faster than the above but have not conducted performance tests.
Dim Cell As Range
For Each Cell In Range("A5:A15").SpecialCells(xlCellTypeBlanks)
Cell.EntireRow.Hidden = True
Next
Try the following
Option Explicit
Sub youcouldhaveatleasttriedtodosomethingyourself()
Dim r1 As Range, r2 As Range, c As Range, target As Range
With Workbooks(REF).Sheets(REF)
Set r1 = .Range("A1:A54")
Set r2 = .Range("F3:F32")
Set target = Application.Union(r1, r2)
For Each area In target.Areas
For Each c In area
If c.Value = vbNullString Then .Rows(c.Row).EntireRow.Hidden = True
Next c
Next area
End With
End Sub
Please note that I now have set two exemplifying ranges. You can always add more range variables to the Union function.
I am trying to write a UDF that will Move or Delete all columns in an array
This part I have.
I also want to Delete or Move all columns not in the array and this part I am stuck on.
This is Case 2 and 4 of the function
Any help on this is appreciated
Thanks
Edit: Updated with answer provided by David G
Function InvertRng(shtName As String, r As Range) As Range
Dim rng As Range
Dim Rng1 As Range, Rng2 As Range
Set Rng1 = GetUsedRange(shtName, 1, True)
For Each rng In Rng1
If Application.Intersect(rng, r) Is Nothing Then
If InvertRng Is Nothing Then
Set InvertRng = rng
Else
Set InvertRng = Application.Union(InvertRng, rng)
End If
End If
Next
End Function
Original Question
Sub MoveOrDelete_n()
MoveOrDelete 2, "Elements", "NewSheet", Array("Id", "Type", "Description")
End Sub
The Function
Function MoveOrDelete(iwhat As Long, SshtName As String, TshtName As String, arrHeaders As Variant) 'Excel VBA to move Columns based on criteria
Dim wsS As Worksheet, wsT As Worksheet
Dim ar As Variant
Dim fn As Range, r As Range
Dim str As String
Dim i As Long
Set wsS = ThisWorkbook.Sheets(SshtName)
Set wsT = ThisWorkbook.Sheets(TshtName)
For i = 0 To UBound(arrHeaders) 'Loop through the Array
Set fn = wsS.Rows("1:1").Find(arrHeaders(i), LookAt:=xlWhole)
str = str & fn.Address & ","
Next i
'Remove the trailing comma from the string
str = Left(str, Len(str) - 1)
Set r = wsS.Range(str).EntireColumn
Select Case iwhat
Case 1
'Delete all columns IN list
r.Delete
Case 2
'Delete all columns NOT in list
invertR.Delete
Case 3
'Move all columns IN List to NEW Sheet
r.Copy wsT.[a1]
Case 4
'Move all columns NOT in List to NEW SheeT
invertR.Copy wsT.[a1]
End Select
End Function
I found this function that invert the selection, maybe is what you need:
Sub InvertSelection()
'Updateby20140314
Dim rng As Range
Dim Rng1 As Range
Dim Rng2 As Range
Dim OutRng As Range
xTitleId = "KutoolsforExcel"
Set Rng1 = Application.Selection
Set Rng1 = Application.InputBox("Range1 :", xTitleId, Rng1.Address, Type:=8)
Set Rng2 = Application.InputBox("Range2", xTitleId, Type:=8)
For Each rng In Rng2
If Application.Intersect(rng, Rng1) Is Nothing Then
If OutRng Is Nothing Then
Set OutRng = rng
Else
Set OutRng = Application.Union(OutRng, rng)
End If
End If
Next
OutRng.Select
End Sub
https://www.extendoffice.com/documents/excel/762-excel-reverse-selections.html
I have the below code that copies numbers (that doesn't have a color) from a range (here D3 to D30) and pastes it into F column staring from row 1 and does some percentile calculation.
Problem is, I noticed that a stray number "5" appears in F column in the first row even though there is no such number in my range D3 - D30.
Sub TPNoRedpass50tablet()
Dim cel As Range
Dim Rng As Range
Dim arr As Variant
Dim i As Long
Application.ScreenUpdating = False
For Each cel In Sheets("TP").Range("TP!$D$3:$D$30")
If cel.Font.Color = 0 Then
If Rng Is Nothing Then
Set Rng = cel
Else
Set Rng = Union(cel, Rng)
End If
End If
Next cel
ReDim arr(Rng.count - 1)
If Not Rng Is Nothing Then
For Each cel In Rng
arr(i) = cel
i = i + 1
Next cel
Sheets("TP").Range("F1").Resize(UBound(arr) + 1).Value = Application.Transpose(arr)
Set Rng = Sheets("TP").Range("F1:I" & Sheets("TP").Cells(Rows.count, "F").End(xlUp).Row)
Sheets("WBR").Range("AH101").Formula = "=PERCENTILE.INC(" & Rng.Address(, , , True) & ",50%)*24"
Sheets("WBR").Range("AH101").Value = Sheets("WBR").Range("AH101").Value
End If
Application.ScreenUpdating = True
End Sub
Try this:
Sub TPNoRedpass50tablet()
Dim cel As Range
Dim Rng As Range
Dim arr As Variant
Dim i As Long
Application.ScreenUpdating = False
For Each cel In Sheets("TP").Range("TP!$D$3:$D$30")
If Rng Is Nothing Then
Set Rng = cel
If cel.Font.Color = 0 Then
Else
Set Rng = Union(cel, Rng)
End If
End If
Next cel
ReDim arr(Rng.count - 1)
If Not Rng Is Nothing Then
For Each cel In Rng
arr(i) = cel
i = i + 1
Next cel
Sheets("TP").Range("F1").Resize(UBound(arr) + 1).Value = Application.Transpose(arr)
Set Rng = Sheets("TP").Range("F1:I" & Sheets("TP").Cells(Rows.count, "F").End(xlUp).Row)
Sheets("WBR").Range("AH101").Formula = "=PERCENTILE.INC(" & Rng.Address(, , , True) & ",50%)*24"
Sheets("WBR").Range("AH101").Value = Sheets("WBR").Range("AH101").Value
End If
Application.ScreenUpdating = True
End Sub
The problem seems to be in the first for each loop. You have a union, which is carried out only the first time, when Rng is not set.
Below is my code. What i want is the code should ignore the case of alphabets whether it is small capital or both.
Private Sub CommandButton1_Click()
Dim ws As Worksheet, tbl As ListObject, row As ListRow
Set ws = Sheets("Sheet1")
Set tbl = ws.ListObjects("Table2")
Dim intValueToFind As String, intValueToFind1 As String, rng As Range, rng1 As Range
Set rng = tbl.ListColumns(1).DataBodyRange
Set rng1 = tbl.ListColumns(2).DataBodyRange
intValueToFind = LCase(Me.ComboBox1.Value)
intValueToFind1 = LCase(Me.TextBox2.Value)
If Not rng Is Nothing Then
For Each rng In rng
If LCase(rng.Value) = intValueToFind Then
If Not rng1 Is Nothing Then
For Each rng1 In rng1
If LCase(rng1.Value) = intValueToFind1 Then
MsgBox ("Group Head under this Account Head already Exist. Please enter the Unique Name...")
Exit Sub
End If
Next rng1
End If
End If
Next rng
End If
Set row = tbl.ListRows.Add
row.Range(1, 1).Value = Me.ComboBox1.Value
row.Range(1, 2).Value = Me.TextBox2.Value
End Sub
kindly review the above code and advise where i am mistaking.
Just cast both sides to lower case (or upper case):
If LCase(rng.Value) = LCase(intValueToFind) Then