Home > Enterprise >  I have a code, which compares two workbooks, copies new data and works, but I need it to copy entire
I have a code, which compares two workbooks, copies new data and works, but I need it to copy entire

Time:11-28

Credit for code is for few editors in Mr . Excel forum. This code works like a charm, but I need it to copy the entire row of the new data, rather than only values from column A. Now I tried to play with true and false statements and etc. but to no avail, I believe it is out of my scope and id like so suggestions or assistance how to achieve my mission. I have simple values, no formulas, just some named columns and thousands of rows in original file and extract file.

Sub AddMissingItems()
    Dim Dic As Object
    Dim Arr() As Variant, outArr() As Variant
    Dim i As Long, k As Long, iRow As Long
    Dim c as long
    
    Set Dic = CreateObject("Scripting.dictionary")
    With Sheets("Sheet1")
        c = .Cells(1, Columns.Count).End(xlToLeft).Column
        Arr = .Range("A1:A" & .Range("A" & .Rows.Count).End(xlUp).Row).Value
        For i = 1 To UBound(Arr, 1)
            If Dic.exists(Arr(i, 1)) = False Then
                Dic.Add (Arr(i, 1)), ""
            End If
        Next
    End With
    With Workbooks("ExtractFile").Worksheets("Sheet1")
        Arr = .Range("A1:A" & .Range("A" & .Rows.Count).End(xlUp).Row).Value
        ReDim outArr(1 To UBound(Arr), 1 To 1)
        
        For i = 1 To UBound(Arr)
            If Dic.exists(Arr(i, 1)) = False Then
                k = k   1
                outArr(k, 1) = Arr(i, 1)
            End If
        Next
    End With
    iRow = Sheets("Sheet1").Range("A" & Rows.Count).End(3).Row   1
    If k <> 0 Then
        Sheets("Sheet1").Range("A" & iRow).Resize(k).Value = outArr
        k = 0
    End If
End Sub


Tried adding Entirerow statement to several places, but to no avail.

CodePudding user response:

Please, try the next adapted code. I commented where I input new variables/code lines:

Sub AddMissingItems()
    Dim Dic As Object, Arr() As Variant, outArr() As Variant
    Dim i As Long, k As Long, iRow As Long, c As Long
    Dim r As Long, j As Long
    
    Set Dic = CreateObject("Scripting.dictionary")
    With Sheets("Sheet1")
        Arr = .Range("A1:A" & .Range("A" & .rows.count).End(xlUp).row).Value
        For i = 1 To UBound(Arr, 1)
            If Dic.Exists(Arr(i, 1)) = False Then
                Dic.Add (Arr(i, 1)), ""
            End If
        Next
    End With
    With Workbooks("ExtractFile.xlsx").Worksheets("Sheet1")
        c = .cells(1, Columns.count).End(xlToLeft).column
        r = .Range("A" & .rows.count).End(xlUp).row 'calculate the last row in A:A, too
        Arr = .Range("A1", .cells(r, c)).Value       'place in the array all existing columns
        ReDim outArr(1 To UBound(Arr), 1 To c) 'extend the redimmed array to all columns
        
        For i = 1 To UBound(Arr)
            If Dic.Exists(Arr(i, 1)) = False Then
                k = k   1
                For j = 1 To c 'iterate between all array columns:
                    outArr(k, j) = Arr(i, j) 'place the value from each column
                Next j
            End If
        Next
    End With
    iRow = Sheets("Sheet1").Range("A" & rows.count).End(3).row   1
    If k <> 0 Then
        Sheets("Sheet1").Range("A" & iRow).Resize(k, UBound(Arr, 2)).Value = outArr 'resize by  columns, too
        k = 0
    End If
End Sub

Please, send some feedback after testing it.

  • Related