vba coding to find match and copy range of data from one workbook to another workbook

Question

I have two excel workbooks: 1- workbook has 19 columns and 8 rows and another workbook has 8 row names and 19 column names same like workbook1 but it doesnt contain any data. I need to copy range of data from workbook1 by exactly matching the rownames.
For example:
Workbook1:

icn id     location
1   125      M
2   123      F
3   132      G
4   145      H
5   145      I

Workbook2:

icn  id  Location
1
3
5
4
2

I tried coding but I was not able to get the range of data :

Sub UpdateW2()

Dim w1 As Worksheet, w2 As Worksheet
Dim c As Range, FR As Long

Application.ScreenUpdating = False

Set w1 = Workbooks("workbookA.xlsm").Worksheets("Sheet1")
Set w2 = Workbooks("workbookB.xlsm").Worksheets("Sheet1")


For Each c In w1.Range("A2", w1.Range("A" & Rows.Count).End(xlUp))
  FR = 0
  On Error Resume Next
  FR = Application.Match(c, w2.Columns("A"), 0)
  On Error GoTo 0
  If FR <> 0 Then w2.Range("C" & FR).Value = c.Offset(, 0)
Next c
Application.ScreenUpdating = True
End Sub

chris neilsen chris neilsen · Accepted Answer · 2018-06-18T00:54:36

Your references are a bit mixed up.

I've refactored your code to:

Loop over the rows in wb2, since this is the sheet you want to update
Look up each row in wb1
If found, copy columns B and C from wb1 to wb2

Note that if Application.Match does not find a match, it does not throw a run time error, it returns an error value (on the other hand Application.WorksheetFunction.Match does throw a run time error)

Sub UpdateW2()
    Dim w1 As Worksheet, w2 As Worksheet
    Dim c As Range
    Dim FR As Variant '<-- use Variant to allow catching a Error value
    Dim ws1Range As Range, ws2Range As Range

    Application.ScreenUpdating = False

    Set w1 = Workbooks("workbookA.xlsm").Worksheets("Sheet1")
    Set w2 = Workbooks("workbookB.xlsm").Worksheets("Sheet1")

    Set ws1Range = w1.Range("A2", w1.Range("A" & w1.Rows.Count).End(xlUp))
    Set ws2Range = w2.Range("A2", w2.Range("A" & w2.Rows.Count).End(xlUp))

    For Each c In ws2Range
        FR = Application.Match(c.Value, ws1Range, 0)
        If Not IsError(FR) Then
            ' Choose ONE of the next three blocks of code

            ' To copy formula and format
            'ws1Range.Cells(FR, 2).Resize(, 2).Copy Destination:=c.Cells(1, 2).Resize(, 2)

            ' to copy only values
            'c.Cells(1, 2).Resize(, 2) = ws1Range.Cells(FR, 2).Resize(, 2)

            ' To copy values and format
            c.Cells(1, 2).Resize(, 2) = ws1Range.Cells(FR, 2).Resize(, 2)
            ws1Range.Cells(FR, 2).Resize(, 2).Copy
            c.Cells(1, 2).Resize(, 2).PasteSpecial Paste:=xlPasteFormats
        End If
    Next c
    Application.ScreenUpdating = True
End Sub

vba coding to find match and copy range of data from one workbook to another workbook

1 Answers