Macro not working after adding two new items

R

regan_2000

New Member
Joined
Mar 7, 2024
Messages
5
Office Version
  1. 365
Platform
  1. Windows
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
 

Attachments

  • aerial_count.PNG
    aerial_count.PNG
    28.3 KB · Views: 12
  • roster_sheet.PNG
    roster_sheet.PNG
    105.3 KB · Views: 10
  • aerial_count_dropdown.PNG
    aerial_count_dropdown.PNG
    39.6 KB · Views: 10

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.
Sort by date Sort by votes
The new items are added when I run your code to create the dropdown.

1712705754331.png



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

How to Post Your VBA Code

Post your VBA code.
www.mrexcel.com www.mrexcel.com
)
 
Upvote 0
Thanks for checking. I've tried again on different sheets and it still isn't displaying for me
 
Upvote 0
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.

1712745414922.png


Regards

Murray
 
Upvote 0
myall_blues said:
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.

View attachment 109729

Regards

Murray
Click to expand...
HI Murray,
Thanks for this, I have checked and I am using Module4 which is the correct one. It still isn't working for me so I am lost why it can work for yourself and rlv0. I'm lost how that can happen
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
Finding one word in a string and outputting the word in the same row
Replies
3
Views
509
Peter_SSs
Peter_SSs
K
  • Solved
adding array elements to vba range variable
Replies
3
Views
420
Spyros13
S
C
  • Question Question
Searching using TextBox and ListBox
Replies
1
Views
251
campbell1093
C
I
  • Question Question
Listbox columns dont alter when i set the width advice please
Replies
4
Views
60
ipbr21054
I
J
  • Question Question
Userform inconsistent responses
Replies
1
Views
210
Candyman8019
C

Forum statistics

Threads
1,224,264
Messages
6,177,510
Members
452,782
Latest member
ZCapitao

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top