VBA : Copy only new information from specific cells in another worksheet

[Katolux182]

Hi Mr Excel Forum,

Following my conversation with Kevin, I post the following issue. I want to copy all the new data from one worksheet to another, using column A as the check for this information. Cells A contains a barcode in alphanumeric form, therefore is unic for each row.
I want to integrate this program into a botton so I can click and get all the new data from a mother sheet.
For the time being it copies, although it copies in the same cell position. ej E on cell E of the new data sheet, while I will want for it to past in the net available cell A on A, E on B, F on C etc)
I dont know how to include a check of Cell A so it only copies new data.
I think I over complicated the code as it takes long for it to do the process.
I include the code, the worksheets are not really relevant and I the have sensite information on them. I am not being able, also, to unstall the addon as it gives me a message error

Thank you for any help I can receive

Sub CopyNewDataWithFormatting()
    Dim x As Workbook, y As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastrow1 As Long, lastrow2 As Long
    Dim destlastrow As Long
    Dim newDataRow As Range
    
    Set x = Workbooks.Open("C:\Users\agmzj\OneDrive\Escritorio\2023-08-28_Seriennummern_KOPIE.xlsx") ' Direction of the database
    Set y = ThisWorkbook ' Use the workbook where the macro is stored as the destination workbook
    
    Set ws1 = x.Sheets("Schlägerübersicht")
    Set ws2 = y.Sheets("Master sheet")
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    lastrow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    lastrow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
    
    ' Loop through each cell in column A in ws1, starting from A3
    For Each newDataRow In ws1.Range("A3:A" & lastrow1)
        ' Check if the value in ws1's column A exists in ws2's column A
        If IsError(Application.Match(newDataRow.Value, ws2.Range("A1:A" & lastrow2), 0)) Then
            ' Value is not found in ws2, so copy specific cells and preserve formatting to ws2
            ws1.Cells(newDataRow.Row, 1).Copy ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Offset(1, 0)
            ws1.Cells(newDataRow.Row, 5).Copy ws2.Cells(ws2.Rows.Count, 5).End(xlUp).Offset(1, 0)
            ws1.Cells(newDataRow.Row, 6).Copy ws2.Cells(ws2.Rows.Count, 6).End(xlUp).Offset(1, 0)
            ws1.Cells(newDataRow.Row, 10).Copy ws2.Cells(ws2.Rows.Count, 10).End(xlUp).Offset(1, 0)
            ws1.Cells(newDataRow.Row, 9).Copy ws2.Cells(ws2.Rows.Count, 9).End(xlUp).Offset(1, 0)
            ws1.Cells(newDataRow.Row, 11).Copy ws2.Cells(ws2.Rows.Count, 11).End(xlUp).Offset(1, 0)
            ws1.Cells(newDataRow.Row, 12).Copy ws2.Cells(ws2.Rows.Count, 12).End(xlUp).Offset(1, 0)
        End If
    Next newDataRow
    
    ' Clear the clipboard
    Application.CutCopyMode = False
    
    ' Close the database workbook without saving changes
    x.Close SaveChanges:=False
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "New Data Transfered", vbaExclamation, "New Data Transfered"
End Sub

 

[Katolux182]

Thats what happenes when I run it

 

[Katolux182]

Ok, I think I solved it. WIll love your guys opinion

Sub CopyNewData()
    Dim x As Workbook, y As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastrow1 As Long, lastrow2 As Long
    Dim destRow As Long
    Dim newDataRow As Range
    Dim uniqueValues As Object
    Dim cell As Range
    
    Set x = Workbooks.Open("C:\Users\agmzj\OneDrive\Escritorio\2023-08-28_Seriennummern_KOPIE.xlsx") ' Direction of the database
    Set y = ThisWorkbook ' Use the workbook where the macro is stored as the destination workbook
    
    Set ws1 = x.Sheets("Schlägerübersicht")
    Set ws2 = y.Sheets("Master sheet")
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    lastrow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    lastrow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
    
    ' Create a dictionary to store unique values from column A in ws2
    Set uniqueValues = CreateObject("Scripting.Dictionary")
    
    ' Fill the dictionary with values from column A in ws2
    For Each cell In ws2.Range("A2:A" & lastrow2)
        uniqueValues(cell.Value) = True
    Next cell
    
    destRow = lastrow2 + 1 ' Start pasting in the next available row in ws2
    
    ' Loop through each cell in column A in ws1, starting from A3
    For Each newDataRow In ws1.Range("A3:A" & lastrow1)
        ' Check if the value in ws1's column A exists in ws2
        If Not uniqueValues.Exists(newDataRow.Value) Then
            ' Value is not found in ws2, so copy specific cells and preserve formatting to ws2
            ws2.Cells(destRow, 1).Value = newDataRow.Value
            ws2.Cells(destRow, 2).Value = newDataRow.Offset(0, 4).Value
            ws2.Cells(destRow, 3).Value = newDataRow.Offset(0, 5).Value
            ws2.Cells(destRow, 4).Value = newDataRow.Offset(0, 9).Value
            ws2.Cells(destRow, 5).Value = newDataRow.Offset(0, 8).Value
            ws2.Cells(destRow, 6).Value = newDataRow.Offset(0, 10).Value
            ws2.Cells(destRow, 7).Value = newDataRow.Offset(0, 11).Value
            destRow = destRow + 1 ' Move to the next row in ws2
            uniqueValues(newDataRow.Value) = True ' Add the value to the uniqueValues dictionary
        End If
    Next newDataRow

    ' Close the database workbook without saving changes
    x.Close SaveChanges:=False
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

 

[kevin9999]

The way I read your code is that it's putting the values into your Master Sheet from columns A-G inclusive, instead of staggering them as your image of that sheet would suggest?
On another point, is the structure of your Schlägerübersicht sheet exactly the same as your Master Sheet, insofar as the headers are on row 2, the data starts on row 3, and the columns align the same?

 

[kevin9999]

I'm about to sign off for the night, but you could try the following code on a copy of your workbooks. I'm assuming that your Schlägerübersicht sheet is exactly the same structure as your Master Sheet as outlined in post #4.

Option Explicit
Sub CopytoWorkbook_V2()
    Dim x As Workbook, y As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set x = Workbooks.Open("C:\Users\agmzj\OneDrive\Escritorio\2023-08-28_Seriennummern_KOPIE.xlsx") 'Direction of database
    Set y = Workbooks.Open("C:\Users\agmzj\OneDrive\Escritorio\Control Program.xlsm") 'Direction of program
    Set ws1 = x.Sheets("Schlägerübersicht")
    Set ws2 = y.Sheets("Master sheet")
    
    Dim d As Object, c As Range, tmp As String, a, i As Long
    Set d = CreateObject("scripting.dictionary")
    a = Application.Transpose(ws1.Range("A3", ws1.Cells(Rows.Count, "A").End(xlUp)))
    For i = 1 To UBound(a, 1)           '<< fill the dictionary with unique values
        d(a(i)) = 1
    Next
    
    For Each c In ws2.Range("A3", ws2.Cells(Rows.Count, "A").End(xlUp))
        tmp = c.Value
        If d.Exists(tmp) Then d.Remove (tmp)    '<< remove the exclusions from the dictionary
    Next c
    
    If ws1.AutoFilterMode Then ws1.AutoFilter.ShowAllData
    With ws1.Range("A2:L" & ws1.Cells(Rows.Count, "L").End(xlUp).Row)            '<< apply the filter using the array of values
        If d.Count > 0 Then
            .AutoFilter 1, Array(d.keys), 7
            .Offset(1).Resize(.Rows.Count - 1).Copy ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
            .AutoFilter
        End If
    End With
End Sub

 

[Alex Blakenburg]

Looks like @kevin9999 got in just before me.

Here is another option also using the dictionary, not as compact as Kevin's but then Kevin potentially still needs to add some code to only copy the selected columns

Sub CopyNewDataWithFormatting_dict()
    Dim x As Workbook, y As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastrow1 As Long, lastrow2 As Long, lastcol1 As Long
    Dim firstdatarow1 As Long
    
    Dim rngShlag As Range, rngMstr As Range, rngUnion As Range
    Dim arrShlag As Variant, arrMstr As Variant
    Dim arrOutRows As Variant, iOut As Long
    Dim outCols As Variant
    Dim i As Long, j As Long
    
    Set x = Workbooks.Open("C:\Users\agmzj\OneDrive\Escritorio\2023-08-28_Seriennummern_KOPIE.xlsx") ' Direction of the database
    Set y = ThisWorkbook ' Use the workbook where the macro is stored as the destination workbook
    
    Set ws1 = x.Sheets("Schlägerübersicht")
    Set ws2 = y.Sheets("Master sheet")
    
    outCols = Array(1, 5, 6, 9, 10, 11, 12)
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
     
    With ws1
        lastrow1 = .Cells(.Rows.Count, "A").End(xlUp).Row
        firstdatarow1 = 3
        lastcol1 = .Cells(firstdatarow1, "A").End(xlToLeft).Column                  ' If row 2 is the heading row change to row 2
        Set rngShlag = .Range(.Cells(1, "A"), .Cells(lastrow1, lastcol1))
        arrShlag = rngShlag.Value
    End With
    
    With ws2
        lastrow2 = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set rngMstr = .Range(.Cells(1, "A"), .Cells(lastrow1, lastcol1))
        arrMstr = rngMstr.Value
    End With
    
    Dim dictMstr As Object, dictKey As String

    Set dictMstr = CreateObject("Scripting.dictionary")
    
    ' Load details range into Dictionary
    For i = 1 To UBound(arrMstr)
        dictKey = arrMstr(i, 1)
        If Not dictMstr.exists(dictKey) Then
            dictMstr(dictKey) = i
        End If
    Next i
    
    ReDim arrOutRows(1 To UBound(arrShlag))
    ' Loop through each cell in column A in ws1, starting from A3
    For i = firstdatarow1 To UBound(arrShlag)
        ' Check if the value in ws1's column A exists in ws2's column A
        dictKey = arrShlag(i, 1)
        If Not dictMstr.exists(dictKey) Then
            iOut = iOut + 1
            arrOutRows(iOut) = i
        End If
    Next i
    
    For j = 0 To UBound(outCols)
        For i = 1 To iOut
            If rngUnion Is Nothing Then
                Set rngUnion = ws1.Cells(arrOutRows(i), outCols(j))
            Else
                Set rngUnion = Union(rngUnion, ws1.Cells(arrOutRows(i), outCols(j)))
            End If
        Next i
        ' copy specific cells and preserve formatting to ws2
        If rngUnion Is Nothing Then Exit For
        rngUnion.Copy ws2.Cells(lastrow2 + 1, outCols(j))
        Set rngUnion = Nothing
    Next j
    
    ' Clear the clipboard
    Application.CutCopyMode = False
    
    ' Close the database workbook without saving changes
    x.Close SaveChanges:=False
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox Title:="New Data Transfered", Prompt:="New Data Transfered", Buttons:=vbExclamation
End Sub

 

[kevin9999]

There's no point in replicating @Alex Blakenburg 's method, so I thought I'd add the following addition to my code in post #5 after Alex's valid observation, and assuming that your Schlägerübersicht sheet is a contiguous block of data.

Option Explicit
Sub CopytoWorkbook_V3()
    Dim x As Workbook, y As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set x = Workbooks.Open("C:\Users\agmzj\OneDrive\Escritorio\2023-08-28_Seriennummern_KOPIE.xlsx") 'Direction of database
    Set y = Workbooks.Open("C:\Users\agmzj\OneDrive\Escritorio\Control Program.xlsm") 'Direction of program
    Set ws1 = x.Sheets("Schlägerübersicht")
    Set ws2 = y.Sheets("Master sheet")
    
    Dim d As Object, c As Range, tmp As String, a, i As Long
    Set d = CreateObject("scripting.dictionary")
    a = Application.Transpose(ws1.Range("A3", ws1.Cells(Rows.Count, "A").End(xlUp)))
    For i = 1 To UBound(a, 1)           '<< fill the dictionary with unique values
        d(a(i)) = 1
    Next
    
    For Each c In ws2.Range("A3", ws2.Cells(Rows.Count, "A").End(xlUp))
        tmp = c.Value
        If d.Exists(tmp) Then d.Remove (tmp)    '<< remove the exclusions from the dictionary
    Next c
    
    If ws1.AutoFilterMode Then ws1.AutoFilter.ShowAllData
    With ws1.Range("A2:L" & ws1.Cells(Rows.Count, "L").End(xlUp).Row)            '<< apply the filter using the array of values
        If d.Count > 0 Then
            .AutoFilter 1, Array(d.keys), 7
            .Offset(1).Resize(.Rows.Count - 1).Copy ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
            .AutoFilter
        End If
    End With
    ws2.Range("B:D,G:H").Clear
    x.Close
End Sub