Code:
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