excelvba

How to append new rows of data to another excel sheet/table?


I have a table of source data like this:

ID Color
B12 Blue
C14 Yellow
J14 Jaune

And I have a named table (in another sheet) where I'd like to send data that looks like this (same structure as source data):

ID Color

I want the vba code to do the following:

  1. check if the target table contains the case IDs in the source data
  2. if the case ID does not exist, append rows from source data to the target table
  3. if the case ID does exist, update records in the target table according to the values in the source data, if the values are different.

It is important that the code never removes rows from the target table. ie if the source data is updated and a row is removed, the target table should still contain any removed rows. so rows can only be added to the target table, or updated if there are matching case IDs in both tables.

EDIT:

here is an answer from another stack question. though I have no clue how to adapt this code to fit my needs:

' COPY, PASTE AND APPEND   
Sub Append()

Dim manager As String, lastrow As Long, i As Integer, k as integer, j as integer
Dim find As Range, bill As String

bill = Sheets("Sheet1").Range("A:A").Value
Do While Not bill = ""
Set find = Sheets("Sheet1").Range("A:A").find(what:=bill, lookat:=xlValues, lookat:=xlWhole)

If find Is Nothing Then

lastrow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).row

For i = 2 To lastrow
    If Cells(i, 2) = "JOHN" Then
    Range(Cells(i, 1), Cells(i, 6)).copy
    Sheets("Sheet13").Range("A300").End(xlUp).Offset(1, 0).PasteSpecial
    End If
Next i

For j = 2 To lastrow
    If Sheets("Sheet1").Cells(j, 2) = "CHARLIE" Then
    Sheets("Sheet1").Range(Cells(j, 1), Cells(j, 6)).copy
    Sheets("Sheet11").Range("A300").End(xlUp).Offset(1, 0).PasteSpecial
    End If
Next j

For k = 2 To lastrow
    If Sheets("Sheet1").Cells(k, 2) = "GEORGE" Then
    Sheets("Sheet1").Range(Cells(k, 1), Cells(k, 6)).copy
    Sheets("Sheet12").Range("A300").End(xlUp).Offset(1, 0).PasteSpecial
    End If
Next k

Else

Sheets("Sheet1").Select

End If
Loop

End Sub

The above script first looks for manager names in the source data and then copies the data to sheets according to the manager names (which I don't need to do, since all my source data should be pasted to the same sheet). also, I don't think the above script is updating any records, which I need to do in my target table.


Solution

  • Dictionary object is a good option for you.

    Sub demo()
        Dim srcSht As Worksheet, desSht As Worksheet
        Dim arrDes, arrSrc, objDic
        Dim i As Long, j As Long
        ' Update sheet name as needed
        Set srcSht = Sheets("Sheet1") ' source sheet
        Set desSht = Sheets("Sheet2") ' dest. sheet
        ' Load data into array
        arrSrc = srcSht.[a1].CurrentRegion.Value
        arrDes = desSht.[a1].CurrentRegion.Value
        Set objDic = CreateObject("scripting.dictionary")
        ' Add data to dict object from dest table
        For i = 1 To UBound(arrDes)
            objDic(arrDes(i, 1)) = arrDes(i, 2)
        Next
        ' Update / insert data into dict object
        For i = 1 To UBound(arrSrc)
            objDic(arrSrc(i, 1)) = arrSrc(i, 2)
        Next
        ' write data to dest table
        desSht.Range("A1").Resize(objDic.Count, 1) = Application.Transpose(objDic.keys)
        desSht.Range("B1").Resize(objDic.Count, 1) = Application.Transpose(objDic.items)
        Set objDic = Nothing
    End Sub
    

    Update

    Question: there are about ~20 columns and it is possible that the number of columns might change, so I need to know how to modify the script to pick up additional columns

    Note: The code supports multiple key columns, but they must be the first N contiguous columns. You can adjust the number of key columns by modifying the constant KEY_COL_CNT as necessary.

    Option Explicit
    Sub demo()
        Dim srcSht As Worksheet, desSht As Worksheet
        Dim arrDes, arrSrc, arrRes()
        Dim objDic, arrItem, sKey As String
        Dim i As Long, j As Long, ColCnt As Long
        Const KEY_COL_CNT As Integer = 2 ' # of key columns
        ' Update sheet name as needed
        Set srcSht = Sheets("Sheet1") ' source sheet
        Set desSht = Sheets("Sheet2") ' dest. sheet
        ' Load data into array
        arrSrc = srcSht.[a1].CurrentRegion.Value
        arrDes = desSht.[a1].CurrentRegion.Value
        ColCnt = UBound(arrDes, 2)
        Set objDic = CreateObject("scripting.dictionary")
        ' Add data to dict object from dest table
        For i = 1 To UBound(arrDes)
            sKey = ""
            For j = 1 To KEY_COL_CNT
                sKey = sKey & "|" & arrDes(i, j)
            Next
            objDic(sKey) = Application.Index(arrDes, i)
        Next
        ' Update / insert data from src table
        For i = 1 To UBound(arrSrc)
            sKey = ""
            For j = 1 To KEY_COL_CNT
                sKey = sKey & "|" & arrSrc(i, j)
            Next
            objDic(sKey) = Application.Index(arrSrc, i)
        Next
        ReDim arrRes(objDic.Count - 1, 1 To ColCnt)
        ' Get items from dict object
        arrItem = objDic.items
        ' Transform to 2D array
        For i = LBound(arrItem) To UBound(arrItem)
            For j = 1 To ColCnt
                arrRes(i, j) = arrItem(i)(j)
            Next j
        Next i
        ' write data to dest table
        desSht.Range("A1").Resize(objDic.Count, ColCnt) = arrRes
        Set objDic = Nothing
    End Sub
    
    

    enter image description here


    Update

    Question: but is it possible to paste the data into an actual table?

    Note: The only difference is expanding the table before updating cells.

        ReDim arrRes(objDic.Count - 1, 1 To ColCnt)
        ' Get items from dict object
        arrItem = objDic.items
        ' Transform to 2D array
        For i = LBound(arrItem) To UBound(arrItem) - 1
            For j = 1 To ColCnt
                arrRes(i, j) = arrItem(i + 1)(j)
            Next j
        Next i
        ' write data to dest table
        Dim rTab As Range
        Set rTab = desSht.Range("A1").Resize(objDic.Count, ColCnt)
        desSht.ListObjects(1).Resize rTab
        Set rTab = desSht.Range("A2").Resize(objDic.Count - 1, ColCnt)
        rTab.Value = arrRes