Private Sub CommandButton1_Click()
Dim dClr As Object, dDate As Object, dTmp As Object, arr, arr1, i&, s$, s1$, s2$, st&, en&, c, r&, j&, rw&
Dim start_Time#, End_Time#
Set dClr = CreateObject("scripting.dictionary")
Set dDate = CreateObject("scripting.dictionary")
Set dTmp = CreateObject("scripting.dictionary")
start_Time = Timer
Application.StatusBar = " Karina Automate Calculation Started : For Visual Planning Report Generate ...."
arr = Sheets("Customer_Color_Codes").[a1].CurrentRegion
For i = 1 To UBound(arr)
dClr(arr(i, 1)) = arr(i, 2)
Next i
With Sheets("Master_Visual")
arr = .[ce10:hd10].Value
For i = 1 To UBound(arr, 2)
dDate(arr(1, i)) = i 'use dictionary instead of "FIND" for date lookup. dDate(date) = column number
Next i
arr = .Range("a11:cd" & .Cells(Rows.Count, 1).End(3).Row) 'Master_Visual columnA to columnCD data assigned to arr
For i = 1 To UBound(arr)
st = dDate(arr(i, 60)) + 2: en = dDate(arr(i, 61)) + 2 'The reason for "+2" is that the date starts in column C of resultsheet.
If st > 2 And en > 2 Then 'If both start and end dates are found
s = arr(i, 1) & "," & arr(i, 2) 'The variable s is the key of the dictionary and its content is Chaine Name & "," & Chaine No.
s1 = "CUST:-" & arr(i, 3) & "-REF: " & arr(i, 7) & "-TDG: " & arr(i, 48) & "-LOADED LINE" & arr(i, 43) & " - ORDERED: " 'Use your method intact, only change worksheet function into vba.
s1 = s1 & arr(i, 8) & " - FAB: " & Format(arr(i, 11), "DD-MMM") & "- CUT DATE: " & Format(arr(i, 27), "DD-MMM") & "-SEW: "
s1 = s1 & Format(arr(i, 60), "DD-MMM") & " TO " & Format(arr(i, 61), "DD-MMM") & " - DEL: " & Format(arr(i, 70), "DD-MMM")
If arr(i, 11) <> "" Then s2 = "T-" Else s2 = "" 'Use your method intact, only change worksheet function into vba.
If arr(i, 9) <> "" Then s2 = s2 & "A-"
If arr(i, 18) <> "" Then s2 = s2 & "O-"
If arr(i, 24) <> "" Then s2 = s2 & "OF-"
If arr(i, 32) = "VA" Then s2 = s2 & "VA-" Else s2 = s2 & "N-"
If arr(i, 33) = "L" Then s2 = s2 & "L" Else s2 = s2 & "N"
If Not dTmp.exists(s) Then 'Assigning all useful data to the dictionary ITEM through a string connection
dTmp(s) = .Cells(i + 10, 1).Interior.Color
End If
dTmp(s) = dTmp(s) & "+" & dClr(arr(i, 3)) & "+" & s1 & "+" & s2 & "+" & st & "+" & en & "+" & i
End If
Next i
End With
Application.DisplayAlerts = False
Application.ScreenUpdating = False
On Error Resume Next
Sheets("Display Report").Delete
On Error GoTo 0
With Sheets("Format")
.Visible = True
.Copy after:=Sheets(Sheets.Count)
.Visible = 2
End With
ActiveSheet.Name = "Display Report"
With Sheets("Display Report")
.[c2:eb2] = dDate.keys 'Export all dates to the worksheet Display Report
.Rows(3).Resize(3).Copy .Rows(3).Resize(3 * dTmp.Count) 'Generate the required data row format
For Each c In dTmp.keys
r = r + 3
arr1 = Split(dTmp(c), "+")
.Cells(r, 1).Resize(2, 2) = Split(c, ",")
For i = 1 To UBound(arr1) Step 6
st = arr1(i + 3): en = arr1(i + 4)
Do Until .Cells(r, st) = "" And .Cells(r, st).MergeCells = False
st = st + 1
en = en + 1
Loop
.Cells(r, st) = arr1(i + 1)
.Cells(r, st).Interior.Color = arr1(i)
.Cells(r, st).WrapText = True
With .Cells(r + 1, st)
.Value = arr1(i + 2)
.Interior.Color = arr1(i)
.NumberFormat = ""
rw = arr1(i + 5)
If Left(.Value, 1) = "T" Then .Characters(Start:=1, Length:=1).Font.Color = IIf(arr(rw, 12) = "", -16776961, -11489280) ' T 'Use your method intact, only change worksheet function into vba.
If Mid(.Value, 3, 1) = "A" Then .Characters(Start:=3, Length:=1).Font.Color = IIf(arr(rw, 10) = "", -16776961, -11489280) ' A
If Mid(.Value, 5, 1) = "O" Then .Characters(Start:=5, Length:=1).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O
If Mid(.Value, 7, 2) = "OF" Then .Characters(Start:=7, Length:=2).Font.Color = IIf(arr(rw, 25) = "", -16776961, -11489280) 'OF
If Mid(.Value, 10, 2) = "VA" Then .Characters(Start:=10, Length:=2).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O
If Mid(.Value, 10, 1) = "N" Then .Characters(Start:=10, Length:=2).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O
If Mid(.Value, 13, 1) = "L" Then .Characters(Start:=13, Length:=2).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O
If Mid(.Value, 12, 1) = "L" Then .Characters(Start:=12, Length:=2).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O
If Mid(.Value, 13, 1) = "N" Then .Characters(Start:=13, Length:=2).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O
If Mid(.Value, 12, 1) = "N" Then .Characters(Start:=12, Length:=2).Font.Color = IIf(arr(rw, 19) = "", -16776961, -11489280) 'O
End With
.Range(.Cells(r, st), .Cells(r, en)).Merge
.Range(.Cells(r + 1, st), .Cells(r + 1, en)).Merge
For j = 7 To 10
With .Range(.Cells(r, st), .Cells(r, en)).Resize(2).Borders(j)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
Next j
Next i
Sheets("Master_Visual").Cells(arr1(i - 1) + 10, 1).Resize(, 2).Copy
.Cells(r, 1).Resize(2, 2).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
Next c
End With
End_Time = Timer
Application.StatusBar = "Karina Automated Planning For Visual Planning Report Completed In " & Format(End_Time - start_Time, "0.000") & "secs"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub