Copy spaced cells from one sheet to another

[tfriedel88]

This is my very first post so please forgive me for anything wrong with this post.

I have a workbook with one sheet. Every day, I create a new report and merge the two based off a unique ID in column "AB". This is part of the code:

T2 = Worksheets("Sheet1 (2)").Cells(x, 17) 'NHA
    T3 = Worksheets("Sheet1 (2)").Cells(x, 10) 'ES&L Status
    T4 = Worksheets("Sheet1 (2)").Cells(x, 14) 'Need dates
    T5 = Worksheets("Sheet1 (2)").Cells(x, 15) 'ECD Dates
    T6 = Worksheets("Sheet1 (2)").Cells(x, 16) 'shop notes
    'T7 = Worksheets("Sheet1 (2)").Cells(x, 23) 'ES&L Member
    T8 = Worksheets("Sheet1 (2)").Cells(x, 24) 'Tier
    T9 = Worksheets("Sheet1 (2)").Cells(x, 13) 'Subzone
    T10 = Worksheets("Sheet1 (2)").Cells(x, 27) 'SOID
    T11 = Worksheets("Sheet1 (2)").Cells(x, 29) 'Material
    T12 = Worksheets("Sheet1 (2)").Cells(x, 30) 'Material Description
    T13 = Worksheets("Sheet1 (2)").Cells(x, 31) 'BOM Item Line Text 1
    T14 = Worksheets("Sheet1 (2)").Cells(x, 32) 'PO# in Long Text?
    T15 = Worksheets("Sheet1 (2)").Cells(x, 33) 'Date Populated


For Irow = 3 To MaxRows
        If DataRange(Irow, 27) = T10 Then 'SOID
            Cells(Irow, 10) = T3
            Cells(Irow, 14) = T4
            Cells(Irow, 15) = T5
            Cells(Irow, 16) = T6
            Cells(Irow, 24) = T8


                If DataRange(Irow, 27) = T10 Then 'SOID
                    If Cells(Irow, 7) = "DETAIL" Then
                        If Cells(Irow, 9) <> "" Then
                            Cells(Irow, 29) = T11
                            Cells(Irow, 30) = T12
                            Cells(Irow, 31) = T13
                            Cells(Irow, 32) = T14
                            Cells(Irow, 33) = T15
                        End If
                    End If
                End If
            Cells(Irow, 28) = "Inital Run"
            Irow = MaxRows
        End If
    Next

My problem is that it is starting to take close to an hour to run this merge and I was told to use array transfer instead of single cell copying. I tried but I when I select, for example, a1, b1, e1, g1 and x1 and try to copy them over to the same cells in the other sheet, they only copy to cells A1:E1. How to I copy them over to the same matching cells if the criteria is met (a1 to a1 while g1 to g1). I'm not sure this is possible if there is columns in between?

Thanks in advance for any and all help!!

 

[tfriedel88]

I have gotten them into two arrays but now I need the best way to manipulate through if statements how to copy over the data.

 

[shknbk2]

You have only posted part of your code above, so I've worked with that little bit to convert it to be array-based. If it doesn't work, more information might be needed.

The theory here is to put the entire row from column 1 to column 33 into an array for both row "x" and for the row "iRow" if the cells in column 27 match. Then, the various elements of the array are updated in the IF block. Finally, the array values are put back from column 1 to column 33 with the updated values and also the values that weren't changed. This can preserve the position of the updated cells.

    Dim aSource As Variant
    Dim aTarget As Variant
    Dim iRow As Integer
    
    With Worksheets("Sheet1 (2)")
        aSource = .Range(.Cells(x, 1), .Cells(x, 33))
        
        For iRow = 3 To MaxRows
            If .Cells(iRow, 27) = aSource(1, 27) Then
                aTarget = .Range(.Cells(iRow, 1), .Cells(iRow, 33))
                aTarget(1, 10) = aSource(1, 10)
                aTarget(1, 14) = aSource(1, 14)
                aTarget(1, 15) = aSource(1, 15)
                aTarget(1, 16) = aSource(1, 16)
                aTarget(1, 24) = aSource(1, 24)
                If aTarget(1, 7) = "DETAIL" And aTarget(1, 9) <> "" Then
                    aTarget(1, 29) = aSource(1, 29)
                    aTarget(1, 30) = aSource(1, 30)
                    aTarget(1, 31) = aSource(1, 31)
                    aTarget(1, 32) = aSource(1, 32)
                    aTarget(1, 33) = aSource(1, 33)
                End If
                aTarget(1, 28) = "Initial Run"
                .Range(.Cells(iRow, 1), .Cells(iRow, 33)) = aTarget
                Exit For
            End If
        Next iRow
    End With

 

[shknbk2]

Use this code instead. The previous one stays within Sheet1 (2) instead of copying those values to the other sheet.

    Dim aSource As Variant
    Dim aTarget As Variant
    Dim iRow As Integer
    
    aSource = Worksheets("Sheet1 (2)").Range(Worksheets("Sheet1 (2)").Cells(x, 1), Worksheets("Sheet1 (2)").Cells(x, 33))
    
    For iRow = 3 To MaxRows
        If Cells(iRow, 27) = aSource(1, 27) Then
            aTarget = Range(Cells(iRow, 1), Cells(iRow, 33))
            aTarget(1, 10) = aSource(1, 10)
            aTarget(1, 14) = aSource(1, 14)
            aTarget(1, 15) = aSource(1, 15)
            aTarget(1, 16) = aSource(1, 16)
            aTarget(1, 24) = aSource(1, 24)
            If aTarget(1, 7) = "DETAIL" And aTarget(1, 9) <> "" Then
                aTarget(1, 29) = aSource(1, 29)
                aTarget(1, 30) = aSource(1, 30)
                aTarget(1, 31) = aSource(1, 31)
                aTarget(1, 32) = aSource(1, 32)
                aTarget(1, 33) = aSource(1, 33)
            End If
            aTarget(1, 28) = "Initial Run"
            Range(Cells(iRow, 1), Cells(iRow, 33)) = aTarget
            Exit For
        End If
    Next iRow

 

[tfriedel88]

Thank you so much! I will test it out this week and reply whether it works or not. If it doesn't, I will add more of the code.

 

[tfriedel88]

Sorry for the delay!
What you gave me helped so much! I changed it a little and put it in several spots that I needed and I was able to merge both reports in under 5 minutes!! Thank you so much for your help!!!!!!!!!!!!!!!!!!

 

[shknbk2]

You're very welcome. I guess it was my turn for the delay! But I'd rather not have needed the excuse of a 24-hour flu to get it.