Copy the same format as the source using arrays

[luis gaspper]

Hello everyone
I have the following code that grabs data from Sheet1 based on ID column

Code: Select all

Sub Test()
    Dim Col As New Collection, Arr, I As Long, J As Long
    On Error Resume Next

    Arr = Sheet1.Range("A7:J" & Sheet1.Cells(Rows.Count, "A").End(xlUp).Row).Value
    For I = 2 To UBound(Arr, 1)
        For J = 2 To UBound(Arr, 2)
            Col.Add Key:=J & Chr(2) & Arr(I, 1), Item:=Arr(I, J)
        Next J
    Next I

    With Sheet2.Range("A7:J" & Sheet2.Cells(Rows.Count, "A").End(xlUp).Row)
        Arr = .Value
        For I = 2 To UBound(Arr, 1)
            For J = 2 To UBound(Arr, 2)
                Arr(I, J) = Col(J & Chr(2) & Arr(I, 1))
            Next J
        Next I
        .Value = Arr
    End With
End Sub

Everything is ok by using arrays (the original file is too large) so arrays are very suitable.
I need to copy the same format of the original grabbed row and the same column width .. the same font and the same font color.
for example : In Sheet1 row 9
The row height is 35 ..the data is horizontal centered and vertical centered ..the font name is "Arial" and the font color is red
I want to copy all the formats of the row when grabbed into sheet2 ..
Hope this will be clear enough when you peruse the test file ... thank you for your cooperation in advance

[HansV]

You cannot copy formatting using an array.
You'd need to copy and paste the rows instead of using an array, but that would probably take too long.

[luis gaspper]

Welcome Mr. Hans
My attempt ... but it take some time.

Code: Select all

Sub Test2()
  Dim coll As New Collection, rng As Range, arr, i As Long, j As Long
  Application.ScreenUpdating = False

  With Sheet1
    Set rng = .Range("A1:J" & .Cells(Rows.Count, "A").End(xlUp).Row)
    arr = rng.Value
  End With

  On Error Resume Next
     For i = 8 To UBound(arr, 1)
         coll.Add Key:=CStr(arr(i, 1)), Item:=i
     Next i
  On Error Resume Next

  'Calculate output
  With Sheet2
    arr = .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row).Value    'Start from A1 (first row on worksheet, to make life easier)
    For i = 8 To UBound(arr, 1)                                           'Loop start from row 8
        On Error Resume Next
           j = coll(CStr(arr(i, 1)))
           If Err.Number = 0 Then                                         'If exist in collection then
              rng.Rows(j).Copy .Cells(i, 1)                               '   copy related row from source range to examined cell
              .Cells(i, 1).EntireRow.RowHeight = rng.Rows(j).RowHeight    '   copy row height value
           End If
        On Error GoTo 0
    Next i
  End With

  Application.ScreenUpdating = True
End Sub

Any improvements to speed up the code would be great ....thanks for any help you may have.

[luis gaspper]

Can you have a look and review the code for more enhancement?

[HansV]

I have no comments.