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
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
Code:
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