Macro not working after adding two new items

[regan_2000]

HI,
Hopefully someone can help.
I have a macro that counts the number of times certain values are in a row. It has been working for years but I need to add 2 new values to count on. For the life of me, the new ones I"m adding don't appear in the dropdown count box.
I don't want to upload the whole excel sheet as it has personal data on it, so hopefully I can add some screenshots to explain and the code
I have added LOG and BA (in red below), but they don't appear in the drop-down box so I can get the count for them.

Help please, thank you


CODE


Option Explicit
Public dropName As String
Public sheetName As String

Private Sub Worksheet_Activate()
dropName = "Drop Down 1"
sheetName = "Sheet2"

Cells.Clear
ActiveSheet.DropDowns(dropName).ListIndex = 0
ActiveSheet.DropDowns(dropName).Text = "SELECT OUTDUTY"

End Sub

Private Sub CreateOutDutyBar()
Dim myDD As DropDown
Dim myRng As Range
Dim onActSub As String

onActSub = sheetName + ".OutdutyShifts"

Set myRng = ActiveSheet.Range("g1:h1")
With myRng
Set myDD = .Parent.DropDowns.Add _
(Left:=.Left, _
Top:=.Top, _
Width:=.Width, _
Height:=.Height)
End With

With myDD
.AddItem ("Stage 2")
.AddItem ("Stage 3")
.AddItem ("Vert 2")
.AddItem ("HAZMAT")
.AddItem ("AERIAL")
.AddItem ("CAPA")
.AddItem ("Pod")
.AddItem ("Comcen")
.AddItem ("USAR 2")
.AddItem ("CAFS 2")
.AddItem ("BA Qual shifts @ 2")
.AddItem ("Chainsaw")
.AddItem ("shifts @ No.1")
.AddItem ("shifts @ No.2")
.AddItem ("BA Van")
.AddItem ("LOG")


.Text = "SELECT OUTDUTY"
.DropDownLines = 2
'.OnAction = onActSub
.OnAction = "Sheet2.OutdutyShifts"
End With

End Sub

Private Sub OutdutyShifts()

Dim arry() As String
Dim i As Integer

With ActiveSheet.DropDowns(Application.Caller)
i = .ListIndex
' .Delete
End With

ReDim arry(0)

Select Case (i)

Case 1: arry(0) = "NoCriteria"
Call OutdutyCount(arry, i + 4)

Case 2: arry(0) = "NoCriteria"
Call OutdutyCount(arry, i + 4)

Case 3: arry(0) = "7"
Call OutdutyCount(arry, i + 4)

Case 4: arry(0) = "H"
Call OutdutyCount(arry, i + 4)

Case 5: ReDim arry(1)
arry(0) = "B31"
arry(1) = "A42"
Call OutdutyCount(arry, i + 4)

Case 6: arry(0) = "K24"
Call OutdutyCount(arry, i + 4)

Case 7: arry(0) = "P"
Call OutdutyCount(arry, i + 4)

Case 8: arry(0) = "C"
Call OutdutyCount(arry, i + 4)

Case 9: arry(0) = "NoCriteria"
Call OutdutyCount(arry, i + 4)

Case 10: ReDim arry(1)
arry(0) = "8"
arry(1) = "9"
Call OutdutyCount(arry, i + 4)

Case 11: arry(0) = "2"
Call OutdutyCount(arry, i + 4)

Case 12: arry(0) = "NoCriteria"
Call OutdutyCount(arry, i + 4)

Case 13: arry(0) = "1"
Call OutdutyCountTwo(arry)

Case 14: arry(0) = "2"
Call OutdutyCountTwo(arry)

Case 15: arry(0) = "BA"
Call OutdutyCount(arry, i + 4)

Case 16: arry(0) = "LOG"
Call OutdutyCount(arry, i + 4)





' Case 12: ReDim arry(8)
' arry(0) = "2"
' arry(1) = "3"
' arry(2) = "4"
' arry(3) = "5"
' arry(4) = "6"
' arry(5) = "7"
' arry(6) = "8"
' arry(7) = "9"
' arry(8) = "C"
' Call OutdutyCount(arry, i - 7)

End Select

ActiveSheet.DropDowns(Application.Caller).Text = "SELECT OUTDUTY"

End Sub

Private Sub OutdutyCount(arrValues() As String, dispoQualCol As Integer)

Dim dispoRow, dispoDateCol, dispoDateRow, yrBeginCol, yrEndCol As Integer
Dim dispoStaffRowBegin, dispoStaffRowEnd, qualTotalCol As Integer
Dim outDutyPrintRow, colNum, countQual, i As Integer
Dim outDutyType, qualSymbol, retireSymbol As String
Dim dispoDateValue As Date

outDutyPrintRow = 3
dispoDateRow = 3
yrBeginCol = Columns("R").Column
yrEndCol = Worksheets("Disposition").Cells(dispoDateRow, yrBeginCol).End(xlToRight).Column
dispoStaffRowBegin = 7
dispoStaffRowEnd = Worksheets("Disposition").Cells(dispoStaffRowBegin, 1).End(xlDown).Row
qualTotalCol = 5
qualSymbol = "x"
retireSymbol = "X"

' If dispoQualCol = 4 Then
' qualSymbol = "1"
' End If




Cells.Clear

For dispoRow = dispoStaffRowBegin To dispoStaffRowEnd

If Worksheets("Disposition").Cells(dispoRow, dispoQualCol) = qualSymbol And _
Worksheets("Disposition").Cells(dispoRow, 4) <> retireSymbol Then

For colNum = 1 To 4

Cells(outDutyPrintRow, colNum) = Worksheets("Disposition").Cells(dispoRow, colNum)

If Cells(outDutyPrintRow, 3) = "SO" Then
Range(Cells(outDutyPrintRow, 1), Cells(outDutyPrintRow, 4)).Select
Selection.Interior.ColorIndex = 3
Selection.Font.ColorIndex = 2
End If

Next colNum

countQual = 0

For dispoDateCol = yrBeginCol To yrEndCol

If IsDate(dispoDateValue) Then

dispoDateValue = Worksheets("Disposition").Cells(dispoDateRow, dispoDateCol).Value

If dispoDateValue <= Date Then

For i = 0 To UBound(arrValues)

If Worksheets("Disposition").Cells(dispoRow, dispoDateCol) = arrValues(i) Then
countQual = countQual + 1
End If

Next i
End If
End If

Next dispoDateCol

Cells(outDutyPrintRow, qualTotalCol) = countQual
outDutyPrintRow = outDutyPrintRow + 1

End If

Next dispoRow

Cells(3, 1).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select

Selection.Sort Key1:=Range("C:C"), Order1:=xlDescending, _
Key2:=Range("E:E"), Order2:=xlDescending, _
Key3:=Range("A:A"), Order3:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal, DataOption3:=xlSortNormal

ActiveWindow.SmallScroll Down:=-66

Columns("E:E").Select
Selection.Font.Bold = True

Cells(3, 1).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select

With Selection
.Font.Name = "Times New Roman"
.Font.Size = 10
.HorizontalAlignment = xlCenter
.Borders(xlEdgeLeft).Weight = xlThick
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlEdgeRight).Weight = xlThick
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
End With

With Columns("A:A")
.EntireColumn.AutoFit
.HorizontalAlignment = xlLeft
.Font.Name = "Arial"
End With

ActiveSheet.Range("A1").Value = ActiveSheet.DropDowns(Application.Caller) _
.List(ActiveSheet.DropDowns(Application.Caller).ListIndex)

Range("A1:E2").Select

With Selection
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
With .Font
.Name = "Arial"
.Size = 20
.Bold = True
End With
End With

End Sub

Private Sub OutdutyCountTwo(arrValues() As String)

Dim dispoRow, dispoDateCol, dispoDateRow, yrBeginCol, yrEndCol As Integer
Dim dispoStaffRowBegin, dispoStaffRowEnd, qualTotalCol As Integer
Dim outDutyPrintRow, colNum, countQual, i As Integer
Dim outDutyType, qualSymbol, retireSymbol As String
Dim dispoDateValue As Date

outDutyPrintRow = 3
dispoDateRow = 3
yrBeginCol = Columns("R").Column
yrEndCol = Worksheets("Disposition").Cells(dispoDateRow, yrBeginCol).End(xlToRight).Column
dispoStaffRowBegin = 7
dispoStaffRowEnd = Worksheets("Disposition").Cells(dispoStaffRowBegin, 1).End(xlDown).Row
qualTotalCol = 5
qualSymbol = "x"
retireSymbol = "X"

' If dispoQualCol = 4 Then
' qualSymbol = "1"
' End If




Cells.Clear

For dispoRow = dispoStaffRowBegin To dispoStaffRowEnd

If Worksheets("Disposition").Cells(dispoRow, 4) <> retireSymbol Then

For colNum = 1 To 4

Cells(outDutyPrintRow, colNum) = Worksheets("Disposition").Cells(dispoRow, colNum)

If Cells(outDutyPrintRow, 3) = "SO" Then
Range(Cells(outDutyPrintRow, 1), Cells(outDutyPrintRow, 4)).Select
Selection.Interior.ColorIndex = 3
Selection.Font.ColorIndex = 2
End If

Next colNum

countQual = 0

For dispoDateCol = yrBeginCol To yrEndCol

If IsDate(dispoDateValue) Then

dispoDateValue = Worksheets("Disposition").Cells(dispoDateRow, dispoDateCol).Value

If dispoDateValue <= Date Then

For i = 0 To UBound(arrValues)

If Worksheets("Disposition").Cells(dispoRow, dispoDateCol) = arrValues(i) Then
countQual = countQual + 1
End If

Next i
End If
End If

Next dispoDateCol

Cells(outDutyPrintRow, qualTotalCol) = countQual
outDutyPrintRow = outDutyPrintRow + 1

End If

Next dispoRow

Cells(3, 1).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select

Selection.Sort Key1:=Range("C:C"), Order1:=xlDescending, _
Key2:=Range("E:E"), Order2:=xlDescending, _
Key3:=Range("A:A"), Order3:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal, DataOption3:=xlSortNormal

ActiveWindow.SmallScroll Down:=-66

Columns("E:E").Select
Selection.Font.Bold = True

Cells(3, 1).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select

With Selection
.Font.Name = "Times New Roman"
.Font.Size = 10
.HorizontalAlignment = xlCenter
.Borders(xlEdgeLeft).Weight = xlThick
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlEdgeRight).Weight = xlThick
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
End With

With Columns("A:A")
.EntireColumn.AutoFit
.HorizontalAlignment = xlLeft
.Font.Name = "Arial"
End With

ActiveSheet.Range("A1").Value = ActiveSheet.DropDowns(Application.Caller) _
.List(ActiveSheet.DropDowns(Application.Caller).ListIndex)

Range("A1:E2").Select

With Selection
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
With .Font
.Name = "Arial"
.Size = 18
.Bold = True
End With
End With

End Sub







Sub Outduties()

End Sub

 

[rlv01]

The new items are added when I run your code to create the dropdown.

(Tip: For future posts , please try to use code tags when posting code. It makes your code easier to read and copy.

How to Post Your VBA Code

Post your VBA code.

www.mrexcel.com

)

 

[regan_2000]

Thanks for checking. I've tried again on different sheets and it still isn't displaying for me

 

[regan_2000]

Here is a link to the document if you could take a quick look to see why it isn't showing for me please!!

D 2024 Roster - testing.xlsm

Shared with Dropbox

www.dropbox.com

 

[myall_blues]

It works ok for me too, but note that you have two versions of the sub CreateOutDutyBar() - one in Module 2 and one in Module 4. Is it possible you're running the wrong one? You have modified the one in Module 4, which when you run it makes a dropbox only 2 lines high according to the line .DropDownLines=2. The one in module 2 appears 14 lines high but has not had the new dropdown elements added.

Regards

Murray