Finding duplicates in array then add a digit

[Thompyt]

The code in Bold is where this fails with Runtime Error '9': Subscript out of range. It was running fine when I only had


Debug.Print cnt, , d1(x, 1) & d1(x, 3) & d1(x, 5), d1(x + 1, 1) & d1(x + 1, 3) & d1(x + 1, 5)

It fails on d1(x + 1, 1) & d1(x + 1, 3) & d1(x + 1, 5). I am trying to count the duplicates in d1(x, 1) to d1(X+1,5) or column 5 next row down where the d1(x, 1) and d1(x, 3) remain the same. Then I want to add in to where the equipment is the same. Once the Like items have been met and the role is the same then add a 2 to the second, 3 to third, etc.

d1(x,5) is like:

PLATOON SERGEANT

PLATOON LEADER

COMBAT MEDIC

RATELO

FIRE SPT SPECIALIST

PLATOON SERGEANT

PLATOON LEADER

COMBAT MEDIC

RATELO

FIRE SPT SPECIALIST

SQUAD LEADER

SQUAD LEADER

AUTOMATIC RIFLEMAN

RIFLEMAN

GRENADIER

FIRE TEAM LEADER

FIRE TEAM LEADER

AUTOMATIC RIFLEMAN

GRENADIER

RIFLEMAN

FIRE TEAM LEADER

FIRE TEAM LEADER

AUTOMATIC RIFLEMAN

Sub RoleS()

    Set WkSht = Nothing
    Set WkSht2 = Nothing
    Set WkSht3 = Nothing
    Set WkBk = Nothing
    
    strTab = "PC22"
    
    Set WkBk = ThisWorkbook
    Set WkSht = Worksheets(strTab)
    Set WkSht2 = Worksheets("UniqueRefer")
    Set WkSht3 = Worksheets("Acronyms")
    Set Rng = WkSht.UsedRange
    Set Rng2 = WkSht2.UsedRange
    Set Rng3 = WkSht3.UsedRange
    
    d1 = Rng.Value
    d2 = Rng2.Value
    d3 = Rng3.Value


        Application.Calculation = xlCalculationManual
        Application.ScreenUpdating = False
 x = 1
    For x = 1 To UBound(d1)
        If d1(x, 1) & d1(x, 3) & d1(x, 5) = d1(x + 1, 1) & d1(x + 1, 3) & d1(x + 1, 5) Then    ' Fails here Runtime Error 9 Subscript out of Range
            w = w + 1
            cnt = w
        Else
            w = 0
            cnt = ""
        End If
    Next x
 x = 1
    For y = 2 To UBound(d2)
        For x = 2 To UBound(d1)
            If d2(y, 1) = d1(x, 1) Then Worksheets(strTab).Cells(x, 2) = d2(y, 2)
            If d2(y, 1) = d1(x, 3) Then Worksheets(strTab).Cells(x, 4) = d2(y, 2) & "-"
            If d2(y, 1) = d1(x, 5) Then Worksheets(strTab).Cells(x, 6) = d2(y, 2) & cnt & "-"
            If d2(y, 5) = d1(x, 8) Then Worksheets(strTab).Cells(x, 11) = d2(y, 6)
            If d1(x, 3) = d1(x, 5) Then d1(x, 6) = ""
        Next x
    Next y
x = 1
    For x = 2 To UBound(d1)
        For z = 2 To UBound(d3)
            If d1(x, 3) = d3(z, 1) Then Worksheets(strTab).Cells(x, 4) = d3(z, 2) & "-"
            If d1(x, 5) = d3(z, 1) Then Worksheets(strTab).Cells(x, 6) = d3(z, 2) & cnt & "-"
         Next z
    Next x
x = 1
    For x = 2 To UBound(d1)
        If d1(x, 3) = d1(x, 5) Then
            Worksheets(strTab).Cells(x, 6) = ""
        Else
            Worksheets(strTab).Cells(x, 6) = d1(x, 6)
        End If
            Worksheets(strTab).Cells(x, 12) = Worksheets(strTab).Cells(x, 11) & Worksheets(strTab).Cells(x, 6) & Worksheets(strTab).Cells(x, 4) & Worksheets(strTab).Cells(x, 2)
    Next x
       Sheets(strTab).Range("A1:M1").EntireColumn.AutoFit
 
 Application.Calculation = xlCalculationAutomatic
 Application.ScreenUpdating = True
 Application.DisplayStatusBar = True
    
End Sub

[Welshgasman]

Arrays start at 0, do they not?, so Ubound(d1)-1 ?

As I keep telling people walk through your code line by line or with breakpoints ​and inspect the variables.

[Thompyt]

Fixed, but if there is a smoother way to do it..........

Sub RoleS()    
    strTab = "PC22"
    
    Set WkSht = Worksheets(strTab)
    Set WkSht2 = Worksheets("UniqueRefer")
    Set WkSht3 = Worksheets("Acronyms")


    Set Rng = WkSht.UsedRange
    Set Rng2 = WkSht2.UsedRange
    Set Rng3 = WkSht3.UsedRange
    
    d1 = Rng.Value
    d2 = Rng2.Value
    d3 = Rng3.Value
    
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    
    RCnt = ActiveSheet.UsedRange.Rows.Count + 1
    w = 0
    y = 1
    x = 1
    z = 1
    
    For iRow = 2 To RCnt
    
          If Cells(iRow, 5) & Cells(iRow, 3) & Cells(iRow, 1) = Cells(iRow + 1, 5) & Cells(iRow + 1, 3) & Cells(iRow + 1, 1) And Cells(iRow, 7) = Cells(iRow + 1, 7) Then
            w = w + 1
            cnt = w
        Else
            w = 0
            cnt = ""
        End If
            Worksheets(strTab).Cells(iRow, 13) = cnt
    Next iRow
          
    For y = 2 To UBound(d2)
        For x = 2 To UBound(d1)
            If d2(y, 1) = d1(x, 1) Then Worksheets(strTab).Cells(x, 2) = d2(y, 2)                                                   ' Unit
            If d2(y, 1) = d1(x, 3) Then Worksheets(strTab).Cells(x, 4) = d2(y, 2) & "-"                                             ' Paragraph
            If d2(y, 1) = d1(x, 5) Then Worksheets(strTab).Cells(x, 6) = d2(y, 2) & Worksheets(strTab).Cells(x, 13) & "-"            ' Count and Roles
            If d2(y, 6) = d1(x, 9) Then Worksheets(strTab).Cells(x, 8) = d2(y, 5) & "-"                                             ' Equipment
                For z = 2 To UBound(d3)
                    If d1(x, 3) = d3(z, 1) Then Worksheets(strTab).Cells(x, 4) = d3(z, 2) & "-"                                     ' roles
                    If d1(x, 5) = d3(z, 1) Then Worksheets(strTab).Cells(x, 6) = d3(z, 2) & Worksheets(strTab).Cells(x, 13) & "-"   ' Count of roles
                    If d1(x, 9) = d3(z, 6) Then Worksheets(strTab).Cells(x, 8) = d3(z, 5) & "-"
                Next z
            If d1(x, 1) = d1(x, 3) Then Worksheets(strTab).Cells(x, 4) = ""
            If d1(x, 3) = d1(x, 5) Then Worksheets(strTab).Cells(x, 4) = ""
                If Worksheets(strTab).Cells(x, 12) = "" Then
                    Worksheets(strTab).Cells(x, 14) = Worksheets(strTab).Cells(x, 6) & Worksheets(strTab).Cells(x, 8) & Worksheets(strTab).Cells(x, 4) & Worksheets(strTab).Cells(x, 2)
                Else
                    Worksheets(strTab).Cells(x, 14) = Worksheets(strTab).Cells(x, 12) & Worksheets(strTab).Cells(x, 6) & Worksheets(strTab).Cells(x, 4) & Worksheets(strTab).Cells(x, 2)
                End If
                    Worksheets(strTab).Cells(x, 15) = Len(Worksheets(strTab).Cells(x, 14))
                
                    If Len(Worksheets(strTab).Cells(x, 14)) > 30 Then
                        Worksheets(strTab).Cells(x, 14).Interior.ColorIndex = 3
                        Worksheets(strTab).Cells(x, 16) = Len(Worksheets(strTab).Cells(x, 14)) - 30 & " Over"
                    Else
                        Worksheets(strTab).Cells(x, 14).Interior.ColorIndex = -4142
                    End If
                
         Next x
    Next y
        
        Sheets(strTab).Range("A1:O1").EntireColumn.AutoFit
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
  
End Sub