I am attempting to speed up the following code. I figured placing it in "memory" and updating it in "memory" is quicker than reading it from a sheet, then writing to the sheet. Then dump the desired information to the sheet at the end. Is d1 not an array in the second code?
This code works:
Code:
Sub RoleS()
strTab = "PC22V2"
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 = Range("A:Z").SpecialCells(xlCellTypeLastCell).Row 'Cells(Rows.Count, 1).End(xlUp)
y = 1
x = 1
z = 1
Worksheets(strTab).Range("N2:P" & RCnt).ClearContents
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) & "-" ' Count and Roles
If d2(y, 6) = d1(x, 9) Then Worksheets(strTab).Cells(x, 8) = d2(y, 5) & Worksheets(strTab).Cells(x, 13) & "-" ' 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, 8) & Worksheets(strTab).Cells(x, 6) & 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, 8) & 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
If Worksheets(strTab).Cells(x, 13) = "" Then Worksheets(strTab).Cells(x, 17) = 1
If Worksheets(strTab).Cells(x, 13) <> "" Then Worksheets(strTab).Cells(x, 17) = Worksheets(strTab).Cells(x, 13)
Next x
Next y
Sheets(strTab).Range("A1:O1").EntireColumn.AutoFit
Call DelSht
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Sub
This is supposed to be the same with the d1(x, 14) replacing Worksheet(StrTab).Cells(x, 14). Here you get an empty value for any d1 items:
Code:
Sub RoleS()
strTab = "PC22V2"
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 = Range("A:Z").SpecialCells(xlCellTypeLastCell).Row 'Cells(Rows.Count, 1).End(xlUp)
ReDim d1(RCnt, 26)
y = 1
x = 1
z = 1
ReDim d1(RCnt, 26)
For y = 2 To UBound(d2)
For x = 2 To UBound(d1)
If d2(y, 1) = d1(x, 1) Then d1(x, 18) = d2(y, 2)
If d2(y, 1) = d1(x, 3) Then d1(x, 19) = d2(y, 2) & "-"
If d2(y, 1) = d1(x, 5) Then d1(x, 20) = d2(y, 2) & "-"
If d2(y, 1) = d1(x, 9) Then d1(x, 21) = d2(y, 2) & d2(y, 13) & "-"
For z = 2 To UBound(d3)
If d1(x, 3) = d3(z, 1) Then d1(x, 19) = d3(z, 2) & "-"
If d1(x, 5) = d3(z, 1) Then d1(x, 20) = d3(z, 2) & d2(y, 13) & "-"
If d1(x, 9) = d3(z, 6) Then d1(x, 21) = d3(z, 5) & "-"
Next z
If d1(x, 1) = d1(x, 3) Then d1(x, 4) = ""
If d1(x, 3) = d1(x, 5) Then d1(x, 4) = ""
If d1(x, 12) = "" Then
d1(x, 14) = d1(x, 8) & d1(x, 6) & d1(x, 4) & d1(x, 2)
Else
d1(x, 14) = d1(x, 12) & d1(x, 6) & d1(x, 8) & d1(x, 4) & d1(x, 2)
End If
d1(x, 15) = Len(d1(x, 14))
Debug.Print "Roles: " & d1(x, 14), , "Out: " & Worksheets(strTab).Cells(x, 14), , "Length: " & d1(x, 15)
If Len(d1(x, 14)) > 30 Then
d1(x, 14).Interior.ColorIndex = 3
d1(x, 16) = Len(d1(x, 14)) - 30 & " Over"
End If
If d1(x, 13) = "" Then d1(x, 17) = 1
If d1(x, 13) <> "" Then d1(x, 17) = d1(x, 13)
Next x
Next y
Sheets(strTab).Range("A1:O1").EntireColumn.AutoFit
Call DelSht
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Sub