Moving different rows data to one row based on criteria to optimise on printing

[大灰狼1976]

Hi VISHAL120!
The cells.interior.color is extracted at the following step:

      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

If you need to copy the complete format, it is more convenient to copy the format.
The whole code is as follows:

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

[VISHAL120]

Hi Okami,

sorry for the late reply .

Thank you a lot it works very well and very quick too.
appreciate your kind help and u thank you a lot on behalf of my team Brother.

by the way brother can give me some tips on how and when we can use scripting dictionary as i see the code has done all the the calculation quick enough whereas i was doing it in 3 steps. As i have a lot of project am working on our own department and am taking much more time to do it and are rather complex operation and we need to automate a lot of process for analysis as these are taking lot of time and also lot of manpower. thanks in advance.

[大灰狼1976]

Hi VISHAL120!
You're welcome.
Dictionary is not very efficient in any case, so we should choose the processing method according to the actual situation.
But most of the problems can be solved efficiently through array + dictionary.
The dictionary is actually very simple in function and use:
d(key)=item
item=d(key)
d.exists(x) to determine whether x exists.