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.
Related
I am trying to delete text between two rows that occur multiple times in my Excel spreadsheet. The number of rows in between the text headers varies each time. One of the row headers remains the same, but the first row header will change each time, from Property A to Property B to Property C. I found an answer that helps me fairly well, but how do I use a wildcard symbol to make my starting string be "Property:*"?
Dim strStart As String, strEnd As String
Dim DELETEMODE As Boolean
Dim DelRng As Range
strStart = "Property: A"
strEnd = "Total"
DELETEMODE = False
For r = 1 To Range("A" & Rows.Count).End(xlUp).Row 'first to last used row
If Range("A" & r).Value = strEnd Then DELETEMODE = False
If DELETEMODE Then
'Create a Delete Range that will be used at the end
If DelRng Is Nothing Then
Set DelRng = Range("A" & r)
Else
Set DelRng = Application.Union(DelRng, Range("A" & r))
End If
End If
If Range("A" & r).Value = strStart Then DELETEMODE = True
Next r
'Delete the Range compiled from above
If Not DelRng Is Nothing Then DelRng.EntireRow.Delete xlShiftUp
Quick example with regard to comments on using find():
Sub test()
With Sheets(1)
Dim lastRow As Long: lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = 1 To lastRow
Dim firstFoundCell As Range: Set firstFoundCell = .Range(.Cells(i, 1), .Cells(lastRow, 1)).Find(what:="Property: ", LookIn:=xlValues, lookat:=xlPart)
If firstFoundCell Is Nothing Then
Exit For
Else
Dim secondFoundCell As Range: Set secondFoundCell = .Range(.Cells(firstFoundCell.Row + 1, 1), .Cells(lastRow, 1)).Find(what:="Property: ", LookIn:=xlValues, lookat:=xlPart)
If secondFoundCell Is Nothing Then
Exit For
Else
Dim deleteRange As Range
If deleteRange Is Nothing Then
Set deleteRange = .Range(.Rows(firstFoundCell.Row + 1), .Rows(secondFoundCell.Row - 1))
Else
Set deleteRange = Union(deleteRange, .Range(.Rows(firstFoundCell.Row + 1), .Rows(secondFoundCell.Row - 1)))
End If
i = firstFoundCell.Row + 1
Set firstFoundCell = Nothing
Set secondFoundCell = Nothing
End If
End If
Next i
If Not deleteRange Is Nothing Then deleteRange.Delete
End With
End Sub
Solution based on filtering followed by processing of visible cell coordinates. Will not work if there is a mismatch between "Property - Total" pairs
Sub DelGaps()
With ActiveSheet
Set Rng = Intersect(.Columns("A"), .UsedRange)
Rng.AutoFilter Field:=1, Criteria1:="=Property*", Operator:=xlOr, Criteria2:="=Total"
On Error GoTo out
Set Rng = Rng.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
ReDim a(0 To Rng.Count - 1)
For Each cl In Rng
a(i) = cl.Row: i = i + 1
Next
For i = UBound(a) To 0 Step -2
rfrom = a(i - 1) + 1
rto = a(i) - 1
If rto > rfrom Then _
.Rows(rfrom & ":" & rto).Interior.Color = vbRed 'Delete
Next
out:
.AutoFilterMode = False
End With
End Sub
Red rows will be deleted
Delete Between Headers and Totals
A Quick Fix
When considering using wild cards, the Like operator should immediately come to mind.
' *** indicates the changes.
Sub QuickFix()
Dim dT As Double: dT = Timer
Const strStart As String = "Property: *" ' ***
Const strEnd As String = "Total" ' ***
Dim DelRng As Range
Dim r As Long ' ***
Dim DELETEMODE As Boolean
For r = 1 To Range("A" & Rows.Count).End(xlUp).Row 'first to last used row
If Range("A" & r).Value = strEnd Then DELETEMODE = False
If DELETEMODE Then
'Create a Delete Range that will be used at the end
If DelRng Is Nothing Then
Set DelRng = Range("A" & r)
Else
Set DelRng = Application.Union(DelRng, Range("A" & r))
End If
End If
If Range("A" & r).Value Like strStart Then DELETEMODE = True ' ***
Next r
'Delete the Range compiled from above
If Not DelRng Is Nothing Then DelRng.EntireRow.Delete xlShiftUp
Debug.Print Timer - dT
End Sub
There are a few issues with this code.
Firstly, it is a little bit slow which is covered in the Improvement in detail and mainly consists of combining the appropriate ranges (not each cell) into the Delete range.
Secondly, let's focus on what will be deleted if your data accidentally has missing Totals. Consider the following extreme-case image:
What should be deleted? Here is what happens after using your amended code.
Here is what I would like to happen covered in the Improvement.
In a nutshell, all Properties should stay alive and rows should only be deleted above the Totals if there previously was a Property row detected. In this case, only row 18 was deleted.
The Improvement
Sub DeleteBetweenHeaders()
Dim dT As Double: dT = Timer
Const strStart As String = "Property: *"
Const strEnd As String = "Total"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim rg As Range
Set rg = ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp))
Dim drg As Range
Dim cell As Range
Dim r As Long
Dim fr As Long
Dim lr As Long
For Each cell In rg.Cells
r = r + 1
If cell.Value Like strStart Then
fr = r + 1 ' write the next row to the first row variable
ElseIf cell.Value = strEnd Then
lr = r - 1 ' write the previous row to the last row variable
If fr > 0 Then ' the first row is set
If lr >= fr Then ' there is a gap
If drg Is Nothing Then
Set drg = rg.Cells(fr).Resize(lr - fr + 1)
Else
Set drg = Union(drg, rg.Cells(fr).Resize(lr - fr + 1))
End If
'Else ' lr < fr i.e. there is no gap; do nothing
End If
fr = 0 ' reset the first row
'Else ' there is no first row yet; do nothing
End If
End If
Next cell
If Not drg Is Nothing Then drg.EntireRow.Delete xlShiftUp
Debug.Print Timer - dT
End Sub
I am trying to loop over a column L in my sheet and then color the cell red if value is not in “big box” and “small box”. The problem is I cannot figure out what I am doing wrong, and VBA is not throwing any errors now.
Sub data_validation_from_array()
Dim packages As Variant
Dim packages_range As Range
Dim cell_value As String
Dim vFilter
Set active_sheet = ActiveSheet
last_row = active_sheet.Range("L" & active_sheet.Rows.Count).End(xlUp).row
Set rng = active_sheet.Range("L2" & last_row)
packages = Array("big box", "small box")
For Each cel In rng
cell_value = cel.Value
vFilter = Filter(packages, cell_value, True)
If Not cell_value = vFilter(i) Then
cel.Interior.Color = vbRed
End If
Next cel
End Sub
Sub data_validation_from_array()
Dim packages_range As Range
Dim cell As Range
Dim last_row As Long
' you should use fully qualified reference here
' WORKSHEET_NAME: the name of the worksheet where the L column is
Set active_sheet = ThisWorkbook.Worksheets("WORKSHEET_NAME")
With active_sheet
last_row = .Range("L" & .Rows.Count).End(xlUp).Row
Set packages_range = .Range("L2", .Cells(last_row, "L"))
End With
For Each cell In packages_range
Select Case cell.Value
Case "big box": cell.Interior.Color = vbRed
Case "small box": cell.Interior.Color = vbRed
End Select
Next cell
Set packages_range = Nothing
Set cell = Nothing
End Sub
I want to highlight cells with the largest value in each row but only using columns F, I, L, O and R.
Sub Highlights()
Dim ws As Worksheet
Dim ColorRng As Range
Dim ColorCell As Range
Set ws = Worksheets("Sheet2")
Set ColorRng = ws.Range("F7,I7,L7,O7,R7")
'highlight the cell that contains the highest and lowest number
For Each ColorCell In ColorRng
If ColorCell.Value = Application.WorksheetFunction.Max(ColorRng) Then
ColorCell.Interior.Color = RGB(0, 180, 40)
ElseIf ColorCell.Value = Application.WorksheetFunction.Min(ColorRng) Then
ColorCell.Interior.Color = RGB(255, 0, 0)
End If
Next
End Sub
It works for the first row (that being row 7), but it doesn't continue to the next row. I realize this is because of my ColorRng range.
How do I allow the range to include more?
Please try this code.
Sub SetHighlights()
Dim ColorRng As Range
Dim ColorCell As Range ' loop object
Dim Mini As Variant
Dim Maxi As Variant
Dim R As Long ' loop counter: rows
Dim C As Long ' loop counter: columns
Dim n As Integer ' result counter
'highlight the cell that contains the highest and lowest number
Application.ScreenUpdating = False
With Worksheets("Sheet2")
For R = 2 To .Cells(.Rows.Count, "F").End(xlUp).Row
Set ColorRng = Union(.Cells(R, "F"), .Cells(R, "I"), _
.Cells(R, "L"), .Cells(R, "R"))
Mini = Application.Min(ColorRng)
Maxi = Application.Max(ColorRng)
For Each ColorCell In ColorRng
With ColorCell
If .Value = Maxi Then
.Interior.Color = RGB(0, 180, 40)
n = n + 1
ElseIf .Value = Mini Then
.Interior.Color = RGB(255, 0, 0)
n = n + 1
End If
End With
If n = 2 Then Exit For
Next ColorCell
Next R
End With
Application.ScreenUpdating = True
End Sub
Observe that the Min and Max functions are run only once per row instead of for each cell as your original code had it. Turning off ScreenUpdating further enhances the speed with which the procedure can complete the job
Give a try on below sub. As you need to highlight in every row, so you have to iterate every row to compare.
Sub Highlights()
Dim ws As Worksheet
Dim ColorRng As Range
Dim ColorCell As Range
Dim lRow As Long
Set ws = Worksheets("Sheet2")
lRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
With ws
For i = 7 To lRow
Set ColorRng = Union(.Range("F" & i), .Range("I" & i), .Range("L" & i), .Range("O" & i), .Range("R" & i))
For Each ColorCell In ColorRng
If ColorCell.Value = Application.Max(ColorRng) Then
ColorCell.Interior.Color = RGB(0, 180, 40)
ElseIf ColorCell.Value = Application.Min(ColorRng) Then
ColorCell.Interior.Color = RGB(255, 0, 0)
End If
Next ColorCell
Set ColorRng = Nothing
Next i
End With
End Sub
Highlight Mins and Maxes
If error values, it will fail.
If no numeric value, then no color.
If max = min, then max color.
Adjust the values in the constants section.
The Code
Option Explicit
Sub highlightMinMax()
Const wsName As String = "Sheet2"
Const FirstRow As Long = 7
Const LastRowColumn As String = "F"
Const ColsList As String = "F,I,L,O,R"
Dim ColorMin As Long: ColorMin = RGB(255, 0, 0) ' 255
Dim ColorMax As Long: ColorMax = RGB(0, 180, 40) ' 2667520
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim rgCols As Range
Dim LastRow As Long
Dim i As Long
Set rgCols = ws.Columns(LastRowColumn)
LastRow = ws.Cells(ws.Rows.Count, LastRowColumn).End(xlUp).Row
If LastRow < FirstRow Then Exit Sub
Dim Cols() As String: Cols = Split(ColsList, ",")
For i = 0 To UBound(Cols)
Set rgCols = getCombinedRangeBasic(rgCols, ws.Columns(Cols(i)))
Next i
Erase Cols
Dim rgColor As Range
Dim cel As Range
Dim rgMin As Range
Dim rgMax As Range
Dim cMin As Double
Dim cMax As Double
For i = FirstRow To LastRow
Set rgColor = Intersect(rgCols, ws.Rows(i))
cMax = Application.Max(rgColor)
cMin = Application.Min(rgColor)
For Each cel In rgColor
If cel.Value = cMax Then
Set rgMax = getCombinedRangeBasic(rgMax, cel)
ElseIf cel.Value = cMin Then
Set rgMin = getCombinedRangeBasic(rgMin, cel)
End If
Next
Next i
If Not rgMin Is Nothing Then
rgMin.Interior.Color = ColorMin
End If
If Not rgMax Is Nothing Then
rgMax.Interior.Color = ColorMax
End If
End Sub
Function getCombinedRangeBasic( _
ByVal BuiltRange As Range, _
ByVal AddRange As Range)
If BuiltRange Is Nothing Then
Set getCombinedRangeBasic = AddRange
Else
Set getCombinedRangeBasic = Union(BuiltRange, AddRange)
End If
End Function
This proposed solution uses FormatConditions
FormatConditions will keep the Mins & Maxs updated when ever the values get changed.
Only need to rerun the procedure when the range changes.
However, FormatConditions are Volatile therefore need to evaluate the size of your data.
…
Sub FormatConditions_MinMax_NonContiguousRow()
Const kIni As Byte = 7
Dim Rng As Range, rRow As Range, lRow As Long
With ThisWorkbook.Sheets("Sheet2") 'Change as required
Rem Disable AutoFilter
If Not (.AutoFilter Is Nothing) Then .AutoFilter.Range.AutoFilter
Rem Set & Validate Last Row
lRow = .Columns("F").Cells(.Rows.Count).End(xlUp).Row
If lRow <= kIni Then Exit Sub
Rem Set Data Range
Set Rng = .Range("F" & kIni & ":R" & lRow)
End With
With Rng
Rem Delete prior FormatConditions
.FormatConditions.Delete
Rem Add FormatConditions by Row
For Each rRow In .Rows
With rRow
Rem Add FormatConditions Max
With .FormatConditions.AddTop10
.SetFirstPriority
.TopBottom = xlTop10Top
.Rank = 1
.Percent = False
.Interior.Color = RGB(255, 0, 0)
.StopIfTrue = True
End With
Rem FormatConditions Min
With .FormatConditions.AddTop10
.SetFirstPriority
.TopBottom = xlTop10Bottom
.Rank = 1
.Percent = False
.Interior.Color = RGB(0, 180, 40)
.StopIfTrue = True
End With
End With: Next
Rem Remove FormatConditions from Other Columns
Application.Intersect(.Cells, Range("G:H,J:K,M:N,P:Q")).FormatConditions.Delete
.Calculate
End With
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 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