Coping Data from One Workbook To Another Based On Cell Data

Question

I am trying to copy data from one workbook to another based on the values contained in cells in the source workbook that matches the same values in the target workbook. For example, I have a table (Table1) that has four columns say, A1:D5. One of these columns (column A) contains account numbers that match similar account numbers located on another workbook (also in column A). I am trying to find a code that looks through the table (Table1) in the source workbook via the account number column, and if the account number matches the account number in the target workbook, copy and paste the cells on that row in specific locations to the target workbook. Is this possible?

I hope that makes sense. I have looked all over on how to structure such a code, and I was not able to find anything to start the process for this logic.

Any help will be very appreciative.

Thank you

Answer 1

Even if your question is about doing this in VBA, I'm just going to mention that what you are trying to do seems like it could also be done with Power Query.

That being said, if you were to use VBA for this, you would have to use the Match function to find where your rows match and then copy the data from the source to the destination table.

I've adapted the code I provided to this question to better serve your specific needs. One of the things I've done is to add an optional argument called DoOverwrite and set it to false. This will make sure that the information from one row won't be overwritten by another row later down the road.

Sub TableJoinTest()

'Those table columns will have to match for the 2 lines to be a match
Dim MandatoryHeaders() As Variant
MandatoryHeaders = Array("Account Number")

Dim SourceTableAnchor As Range
Set SourceTableAnchor = Workbooks("SourceWorkbook.xlsx").Sheets("Sheet1").Range("A1")

Dim TargetTableAnchor As Range
Set TargetTableAnchor = Workbooks("TargetWorkbook.xlsx").Sheets("Sheet1").Range("A1")

TableJoin _
            SourceTableAnchor:=SourceTableAnchor, _
            TargetTableAnchor:=TargetTableAnchor, _
            MandatoryHeaders:=MandatoryHeaders, _
            AddIfMissing:=False, _
            IsLogging:=False, _
            DoOverwrite:=False

End Sub

Sub TableJoin( _
                SourceTableAnchor As Range, _
                TargetTableAnchor As Range, _
                MandatoryHeaders As Variant, _
                Optional OtherHeaders As Variant, _
                Optional AddIfMissing As Boolean = False, _
                Optional IsLogging As Boolean = False, _
                Optional DoOverwrite As Boolean = True)
 
    '''''''''''''''''''''''''''''''''''''''
    'Definitions
    '''''''''''''''''''''''''''''''''''''''
    Dim srng As Range, trng As Range
    Set srng = SourceTableAnchor.CurrentRegion
    Set trng = TargetTableAnchor.CurrentRegion
    
    Dim sHeaders As Range, tHeaders As Range
    Set sHeaders = srng.Rows(1)
    Set tHeaders = trng.Rows(1)
    
    'Store in Arrays
    
    Dim sArray() As Variant 'prefix s is for Source
    sArray = ExcludeRows(srng, 1).Value2
    
    Dim tArray() As Variant 'prefix t is for Target
    tArray = ExcludeRows(trng, 1).Value2
    
    Dim sArrayHeader As Variant
    sArrayHeader = sHeaders.Value2
    
    Dim tArrayHeader As Variant
    tArrayHeader = tHeaders.Value2
    
    'Find Column correspondance
    Dim sMandatoryHeadersColumn As Variant
    ReDim sMandatoryHeadersColumn(LBound(MandatoryHeaders) To UBound(MandatoryHeaders))
    Dim tMandatoryHeadersColumn As Variant
    ReDim tMandatoryHeadersColumn(LBound(MandatoryHeaders) To UBound(MandatoryHeaders))
    
    Dim k As Long
    For k = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
        sMandatoryHeadersColumn(k) = Application.Match(MandatoryHeaders(k), sArrayHeader, 0)
        tMandatoryHeadersColumn(k) = Application.Match(MandatoryHeaders(k), tArrayHeader, 0)
    Next k

    Dim sOtherHeadersColumn As Variant
    ReDim sOtherHeadersColumn(LBound(OtherHeaders) To UBound(OtherHeaders))
    Dim tOtherHeadersColumn As Variant
    ReDim tOtherHeadersColumn(LBound(OtherHeaders) To UBound(OtherHeaders))

    For k = LBound(OtherHeaders) To UBound(OtherHeaders)
        sOtherHeadersColumn(k) = Application.Match(OtherHeaders(k), sArrayHeader, 0)
        tOtherHeadersColumn(k) = Application.Match(OtherHeaders(k), tArrayHeader, 0)
    Next k
    
    
    'Merge mandatory headers into one column (aka the helper column method)
    Dim i As Long, j As Long
    
    Dim sHelperColumn() As Variant
    ReDim sHelperColumn(LBound(sArray, 1) To UBound(sArray, 1), 1 To 1)
    
    For i = LBound(sArray, 1) To UBound(sArray, 1)
        For j = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
          sHelperColumn(i, 1) = sHelperColumn(i, 1) & sArray(i, sMandatoryHeadersColumn(j))
        Next j
    Next i
    
    Dim tHelperColumn() As Variant
    ReDim tHelperColumn(LBound(tArray, 1) To UBound(tArray, 1), 1 To 1)
    
    For i = LBound(tArray, 1) To UBound(tArray, 1)
        For j = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
          tHelperColumn(i, 1) = tHelperColumn(i, 1) & tArray(i, tMandatoryHeadersColumn(j))
        Next j
    Next i
    
    'Find all matches
    Dim MatchList() As Variant
    
    Dim LoggingColumn() As String
    ReDim LoggingColumn(LBound(tArray, 1) To UBound(tArray, 1), 1 To 1)
    
    For i = LBound(sArray, 1) To UBound(sArray, 1)
        ReDim MatchList(LBound(tArray, 1) To UBound(tArray, 1))
        For j = LBound(tArray, 1) To UBound(tArray, 1)
            If sHelperColumn(i, 1) = tHelperColumn(j, 1) Then
                MatchList(j) = 1
            End If
        Next j
        
        'Get the row number for the match
        Dim MatchRow As Long
        
        Select Case Application.Sum(MatchList)

        Case Is > 1
        
            'Need to do more matching
            Dim MatchingScoresList() As Long
            ReDim MatchingScoresList(1 To UBound(tArray, 1))
            
            Dim m As Long
            
            For k = LBound(OtherHeaders) To UBound(OtherHeaders)
                For m = LBound(tArray, 1) To UBound(tArray, 1)
                    If tArray(m, sOtherHeadersColumn(k)) = sArray(i, sOtherHeadersColumn(k)) Then
                        MatchingScoresList(m) = MatchingScoresList(m) + 2 ^ (UBound(OtherHeaders) - k)
                    End If
                Next m
            Next k
            
            'Get the max score position
            Dim MyMax As Long
            MyMax = Application.Max(MatchingScoresList)
            If Application.Count(Application.Match(MatchingScoresList(), Array(MyMax), 0)) > 1 Then
                MsgBox "Error: can't determine how to match row " & i & " in source table"
                Exit Sub
            Else
                MatchRow = Application.Match(MyMax, MatchingScoresList, 0)
            End If
            
        Case Is = 1
        
            MatchRow = Application.Match(1, MatchList, 0)
            
        Case Else
            Dim nArray() As Variant, Counter As Long
            If AddIfMissing Then
                MatchRow = 0
                Counter = Counter + 1
                ReDim nArray(1 To Counter, 1 To UBound(tArray, 2))
                For k = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
                    nArray(Counter, tMandatoryHeadersColumn(k)) = sArray(i, sMandatoryHeadersColumn(k))
                Next k
                For k = LBound(OtherHeaders) To UBound(OtherHeaders)
                    nArray(Counter, tOtherHeadersColumn(k)) = sArray(i, sOtherHeadersColumn(k))
                Next k
            Else
                MsgBox "Error: Couldn't find a match for data row #" & i
                Exit Sub
            End If
        End Select
        
        
        'Logging and assigning values
        If MatchRow > 0 Then
            For k = LBound(OtherHeaders) To UBound(OtherHeaders)
                If tArray(MatchRow, tOtherHeadersColumn(k)) <> sArray(i, sOtherHeadersColumn(k)) Then
                   'Logging
                    If IsLogging And DoOverwrite Then LoggingColumn(MatchRow, 1) = LoggingColumn(MatchRow, 1) & _
                                                    IIf(LoggingColumn(MatchRow, 1) <> "", ", ", "") & _
                                                    tHeaders.Cells(1, tOtherHeadersColumn(k)) & " : " & _
                                                    tArray(MatchRow, tOtherHeadersColumn(k)) & _
                                                    " -> " & sArray(i, sOtherHeadersColumn(k))
                    'Assign new value
                    If DoOverwrite Or tArray(MatchRow, tOtherHeadersColumn(k)) = VbNullString Then
                        tArray(MatchRow, tOtherHeadersColumn(k)) = sArray(i, sOtherHeadersColumn(k))
                    End If
                End If
            Next k
        End If
        
    Next i
    
    'Write arrays to sheet
    ExcludeRows(trng, 1).Value2 = tArray
    With trng.Parent
        If IsArrayInitialised(nArray) And AddIfMissing Then
            .Cells(trng.Cells(1, 1).Row + trng.Rows.Count, trng.Cells(1, 1).Column).Resize(UBound(nArray, 1), UBound(nArray, 2)).Value2 = nArray
        End If
        If IsLogging Then
            .Cells(trng.Cells(1, 1).Row, trng.Cells(1, 1).Column + trng.Columns.Count) = "Changes"
            .Cells(trng.Cells(2, 1).Row, trng.Cells(1, 1).Column + trng.Columns.Count).Resize(UBound(LoggingColumn, 1), 1).Value2 = LoggingColumn
        End If
    End With

End Sub

And also add these functions inside your VBA project to as they are used in the procedure above.

Function IsArrayInitialised(ByRef A() As Variant) As Boolean
    On Error Resume Next
    IsArrayInitialised = IsNumeric(UBound(A))
    On Error GoTo 0
End Function


Function ExcludeRows(MyRng As Range, StartRow As Long, Optional EndRow As Long = -1) As Range
'PURPOSE: Exclude one or more consecutives rows from an existing range

Dim Afterpart As Range, BeforePart As Range

If StartRow < 1 Or EndRow > MyRng.Rows.Count Then Set ExcludeRows = Nothing
If StartRow = 1 And EndRow = MyRng.Rows.Count Then Set ExcludeRows = Nothing

If EndRow = -1 Then EndRow = StartRow

    If EndRow < MyRng.Rows.Count Then
        With MyRng.Parent
            Set Afterpart = .Range(MyRng.Cells(EndRow + 1, 1), MyRng.Cells(MyRng.Rows.Count, MyRng.Columns.Count))
        End With
    End If
    
    If StartRow > 1 Then
        With MyRng.Parent
            Set BeforePart = .Range(MyRng.Cells(1, MyRng.Cells(1, 1).Column), MyRng.Cells(StartRow - 1, MyRng.Columns.Count))
        End With
    End If
    
    
    Set ExcludeRows = Union2(True, BeforePart, Afterpart)
        
End Function

Public Function Union2(IgnoreEmptyRange As Boolean, ParamArray RangeArray() As Variant) As Range
'PURPOSE: Samae as Application.Union but allows some range object to be Empty

    Dim V As Variant
    Dim Rng As Range
    For Each V In RangeArray
    Do
        If VarType(V) = vbEmpty Then Exit Do

        Set Rng = V
        
        If Not Union2 Is Nothing Then
            Set Union2 = Union(Union2, Rng)
        ElseIf Not Rng Is Nothing Then
            Set Union2 = Rng
        End If
        
    Loop While False
    Next
    
End Function