copy data from sheet to another doesn't copy correctly

[abdelfattah]

hello
I try matching data based on column B in sheet1 with column A in sheet2 and copy data from column K : U in sheet1 to column H:R in sheet2
I want fix this code ,please?

Sub match_copy()
Dim lRow, x As Long, ws As Worksheet

Set ws = Sheets("Sheet1")
lRow = ws.Range("B1").End(xlDown).Row

For Each cell In Range("B2:B" & lRow)
    x = 2
    Do
        If cell.Value = Sheets("Sheet2").Cells(x, "A").Value Then
        Sheets("Sheet2").Cells(x, "H").Value = cell.Resize(, 19).Value
        
        End If
        x = x + 1
    Loop Until IsEmpty(Sheets("Sheet2").Cells(x, "A"))
Next
Sheets("Sheet2").Activate
    
End Sub

 

[GWteB]

How about ...

Sub match_copy()

    'I try matching data based on column B in sheet1 with column A in sheet2
    ' and copy data from column K : U in sheet1 to column H:R in sheet2
    
    Dim lRow As Long, x As Long, ws As Worksheet, Rng As Range

    Set ws = Sheets("Sheet1")
    lRow = ws.Range("B1").End(xlDown).Row
    With Sheets("Sheet2")
        For Each Rng In ws.Range("B2:B" & lRow)
            x = 2
            Do
                If Rng.Value = .Cells(x, "A").Value Then
                    .Cells(x, "H").Resize(1, 11).Value = Rng.Offset(0, 9).Resize(1, 11).Value
                End If
                x = x + 1
            Loop Until IsEmpty(.Cells(x, "A"))
        Next
        .Activate
    End With
    
End Sub

 

[abdelfattah]

great help ! just ask about array if I add using array to make the code more fast for at least 2500 rows . is it simple? or I have to issue new thread .

 

[GWteB]

The code below uses arrays only for the purpose of comparisons. Because non-contiguous data is copied, the use of arrays for the latter becomes considerably more difficult, but not impossible.

Sub abdelfattah()
    
    Dim i As Long, k As Long, arrSrc As Variant, arrDest As Variant
    Dim wsSrc As Worksheet, wsDest As Worksheet

    Set wsSrc = Sheets("Sheet1")
    Set wsDest = Sheets("Sheet2")
    arrSrc = wsSrc.Range("B1", wsSrc.Cells(wsSrc.Rows.Count, "B").End(xlUp)).Value
    arrDest = wsDest.Range("A1", wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp)).Value
    
    For i = 2 To UBound(arrSrc)
        For k = 2 To UBound(arrDest)
            If arrSrc(i, 1) = arrDest(k, 1) Then
               wsDest.Cells(k, "H").Resize(1, 11).Value = wsSrc.Cells(i, "K").Resize(1, 11).Value
            End If
        Next k
    Next i
    wsDest.Activate
End Sub

 

[abdelfattah]

not bad . it 's still slow but it's better . the first gives running speed 51.2 for about 1800 rows and second gives 25.0
any way thanks for your codes and times

 

[GWteB]

You are welcome and thanks for the follow-up. Perhaps those run times can be reduced even further. When I have an acceptable attempt I'll post it in this thread.

 

[GWteB]

Perhaps this code may speed things up. Note the separate function to determine the bottom also most right populated cell within a certain range.

Sub abdelfattah_NEW()
    
    Dim i As Long, k As Long, n As Long
    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim arrSrcComp As Variant, arrDestComp As Variant, arrDestData As Variant, arrSrcData As Variant

    Set wsSrc = Sheets("Sheet1")
    Set wsDest = Sheets("Sheet2")
    arrSrcComp = wsSrc.Range("B1", wsSrc.Cells(wsSrc.Rows.Count, "B").End(xlUp)).Value
    arrDestComp = wsDest.Range("A1", wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp)).Value
    arrSrcData = wsSrc.Range("A1", LastPopulatedCell(wsSrc.Cells)).Value
    arrDestData = wsDest.Range("A1", LastPopulatedCell(wsDest.Cells)).Formula

    For i = 2 To UBound(arrSrcComp)
        For k = 2 To UBound(arrDestComp)
            If arrSrcComp(i, 1) = arrDestComp(k, 1) Then
                For n = 8 To 18
                    arrDestData(k, n) = arrSrcData(i, n + 3)
                Next n
            End If
        Next k
    Next i
    wsDest.Range("A1").Resize(UBound(arrDestData, 1), UBound(arrDestData, 2)).Formula = arrDestData
    wsDest.Activate
End Sub

Public Function LastPopulatedCell(ByVal argRng As Range) As Range
    Dim x As Long, y As Long
    If Not argRng Is Nothing Then
        On Error Resume Next
        x = argRng.Find(What:="*", After:=argRng.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
        y = argRng.Find(What:="*", After:=argRng.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
        Set LastPopulatedCell = argRng.Parent.Cells(y, x)
        If Err.Number > 0 Then
            Set LastPopulatedCell = argRng.Cells(1)
            Err.Clear
        End If
    End If
End Function

 

[abdelfattah]

wow ! it's very impressive . running speed gives 1.52 . big difference comparability with the others code.

thanks so much genius

 

[GWteB]

Glad to help.