Match key and import data in column Q&R

[VbaHell]

Hello all

I hope you can help on this please

I am trying to modify the code below, I have the primary key match working but I want to copy all the data in column "Q" and "R" back into my main sheet instead on just copying new rows
Can someone please help

Sub Update1()
    Dim myDir As String, fn As String, uid As String
    Dim originalValues()
    Dim r As Range
    Dim wb As Workbook
    Dim i As Long
    Dim r1 As Range
    On Error GoTo error_trap
    Application.ScreenUpdating = False
    Set r = Range("A1", Cells(Rows.Count, 1).End(xlUp)(1, 18))
    ReDim Preserve originalValues(1 To r.Rows.Count)
    For i = 1 To r.Rows.Count
        originalValues(i) = r.Cells(i, 7) & r.Cells(i, 11) & r.Cells(i, 12)
    Next i
    myDir = ThisWorkbook.Path & "\"
    fn = Dir(myDir & "*.xlsx*")
    Do While fn <> ""
        If fn <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(myDir & fn)
            With wb.Sheets(1)
                Set r1 = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)(1, 18))
                With r1
                    If .Count > 1 Then
                        For i = 2 To .Rows.Count
                        uid = .Cells(i, 7) & .Cells(i, 11) & .Cells(i, 12)
                        If IsError(Application.Match(uid, originalValues, False)) Then
                            r1.Rows(i).Copy r.Parent.Range("A" & r.Parent.Rows.Count).End(xlUp).Offset(1)
                        End If
                        Next i
                    End If
                End With
            End With
            wb.Close False
            Set wb = Nothing
        End If
        fn = Dir
    Loop
    ThisWorkbook.Activate
    Application.ScreenUpdating = True
    Exit Sub
error_trap:
    If Not wb Is Nothing Then wb.Close False
Set wb = Nothing
    ThisWorkbook.Activate
    Application.ScreenUpdating = True
    MsgBox Err.Number & ":" & vbLf & Err.Description, vbCritical, "Error"
End Sub

 

[offthelip]

I think all you need to do is delete ar few rows so change:

uid = .Cells(i, 7) & .Cells(i, 11) & .Cells(i, 12) 
 If IsError(Application.Match(uid, originalValues, False)) Then
       r1.Rows(i).Copy r.Parent.Range("A" & r.Parent.Rows.Count).End(xlUp).Offset(1)
 End If

to

                            r1.Rows(i).Copy r.Parent.Range("A" & r.Parent.Rows.Count).End(xlUp).Offset(1)

 

[VbaHell]

Hi Offthelip

Thanks for your reply but I have a question please
the uid code identifies the primary key which is column 7,11,12

If I remove these two lines how is the code going to match each line and update columns "Q" & "R"

 

[offthelip]

Your definition of what your problem is is not clear, so I can't help you.