Copy then paste to specific cells where criteria matches

[Smiddy243]

Hello everyone!

I have an excel file where some data is provided by other teams (call this the "Source"). I need to take this information and copy it to specific columns in another excel workbook (not worksheet) (call this the Destination) where the Province matches in both worksheets. I am using Excel 2016.

The code I have for this is contained in MY worksheet - not the worksheet that is provided to my by the other teams.

The code I'm providing works up to the line I've colored in Red....I can't seem to get past this. This is only to copy 1 column of data and place it into another column in my destination excel for simplicity sake. In reality I would have about 25 other columns to paste to. If I can figure out just 1 column, I can do the rest.

Dim j As Long, k As Long, lastrowsource As Long, lastrowdestination As Long
Dim myname As String
    Set destination = Workbooks("Provincial Final Data.xlsx").Worksheets("Final Data")
    Set source = Workbooks("Team Input.xlsx").Worksheets("Team Input")


lastrowsource = Workbooks("Team Input").Worksheets("Team Input").Range("L" & Rows.Count).End(xlUp).Row


For j = 5 To lastrowsource
Province = source.Cells(j, "L").Value
destination.Activate
lastrowdestination = Workbooks("Provincial Final Data.xlsx").Worksheets("Final Data").Range("A" & Rows.Count).End(xlUp).Row


For k = 8 To lastrowdestination


If destination.Cells(k, "A").Value = Province Then
source.Activate
source.Range(Cells(j, "I"), Cells(j, "I")).Copy
destination.Activate
destination.Range(Cells(k, "G"), Cells(k, "G")).Select
destination.Paste
End If


Next k
Application.CutCopyMode = False
Next j
destination.Activate
destination.Range("A1").Select


End Sub

 

[Smiddy243]

Dang it - I made a typo....

where I declare myname as string....should be Province as string....

Sorry for the confusion

 

[mumps]

Make sure both workbooks are open. Without having access to your workbooks, I couldn't test this macro but give it a try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, srcWS As Worksheet, fnd As Range, province As Range
    Set desWS = ThisWorkbook.Sheets("Final Data")
    Set srcWS = Workbooks("Team Input.xlsx").Sheets("Team Input")
    For Each province In srcWS.Range("L2", srcWS.Range("L" & srcWS.Rows.Count).End(xlUp))
        Set fnd = desWS.Range("A:A").Find(province, LookIn:=xlValues, lookat:=xlWhole)
        If Not fnd Is Nothing Then
            fnd.Offset(, 6).Value = province.Offset(, -3).Value
        End If
    Next province
    Application.ScreenUpdating = True
End Sub