• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Compare two List Objects multiple columns and add-delete rows

Ajesh

Active Member
Hi Guys,

I have two List Objects TableA and TableB in two different sheets i.e. sht_Source and sht_Dest in same workbook. There are three common columns in both the tables - Type, OriginCode and DestinationCode. What I am trying to accomplish here is to automatically update TableB based on TableA. Sheet2 in which TableB is present is protected and User is not allowed to add/delete any row on his/her own. User can update values in TableB for columns other than the above three columns.

On sht_Dest activate, following actions need to be performed by Macro:
a) If a combination of Type, OriginCode and DestinationCode is present in TableA but not in TableB - Add new row in TableB and fill values in these three columns based on TableA
b) If a combination of Type, OriginCode and DestinationCode is not present in TableA but present in TableB - Delete that row from TableB
c) If a combination of Type,OriginCode and DestinationCode is present in both tables - Do nothing and ignore that row.

I am just a beginner in VBA and have tried to develop the below code which works fine as of now but I am sure the Experts here will have a much cleaner and robust way to address the situation. Is there a better approach to achieve the above specified objectives and/or optimize the below code?

Thanks for your help in advance.

Here's my code:

Code:
Private Sub Worksheet_Activate()
Dim sSht As Worksheet
Dim dSht As Worksheet
Dim sLO As ListObject
Dim dLO As ListObject
Dim OnDType As String, oAC As String, dAC As String
Dim i As Long, j As Long, col As Long
Dim mFound As Boolean
Dim rng As Range, lastRow As Range
Dim NewData(2)

Application.ScreenUpdating = False

Set sSht = ThisWorkbook.Worksheets("sht_Source")
Set dSht = ThisWorkbook.Worksheets("sht_Routes")
Set sLO = sSht.ListObjects("TableA")
Set dLO = dSht.ListObjects("TableB")
mFound = False

dSht.Unprotect Password:="Open"
'Check and Delete unwanted rows from TableB
With dLO
    dLstRow = .ListRows.Count
    If dLstRow >= 1 Then
        For i = .ListRows.Count To 1 Step -1
            OnDType = .ListColumns("Type").DataBodyRange(i)
            oAC = .ListColumns("OriginCode").DataBodyRange(i)
            dAC = .ListColumns("DestinationCode").DataBodyRange(i)
            With sLO
                sLstRow = .ListRows.Count
                If sLstRow >= 1 Then
                    For j = .ListRows.Count To 1 Step -1
                        If .ListColumns("Type").DataBodyRange(j) = OnDType And _
                            .ListColumns("OriginCode").DataBodyRange(j) = oAC And _
                            .ListColumns("DestinationCode").DataBodyRange(j) = dAC Then
                            mFound = True
                            Exit For
                        Else
                            mFound = False
                        End If
                    Next j
                Else
                    mFound = False
                End If
            End With
            If mFound = False Then
                .ListRows(i).Delete
            End If
        Next i
    End If
End With

'Add missing rows and data in TableB
With sLO
    For i = 1 To .ListRows.Count
        OnDType = .ListColumns("Type").DataBodyRange(i)
        oAC = .ListColumns("OriginCode").DataBodyRange(i)
        dAC = .ListColumns("DestinationCode").DataBodyRange(i)
        With dLO
            For j = 1 To .ListRows.Count
                If .ListColumns("Type").DataBodyRange(j) = OnDType And _
                    .ListColumns("OriginCode").DataBodyRange(j) = oAC And _
                    .ListColumns("DestinationCode").DataBodyRange(j) = dAC Then
                    mFound = True
                    Exit For
                Else
                    mFound = False
                End If
            Next j
        End With
        If mFound = False Then
            With dLO
                If .ListRows.Count > 0 Then
                    Set lastRow = .ListRows(.ListRows.Count).Range
                    If Application.CountBlank(lastRow) < lastRow.Columns.Count Then
                        .ListRows.Add
                        dLstRow = dLstRow + 1
                    End If
                End If
                'Iterate through the last row and populate it with the entries from values()
                If .ListRows.Count = 0 Then 'If table is totally empty, set lastRow as first entry
                    .ListRows.Add Position:=1
                    Set lastRow = .ListRows(1).Range
                Else
                    Set lastRow = .ListRows(.ListRows.Count).Range
                End If
                NewData(0) = OnDType
                NewData(1) = oAC
                NewData(2) = dAC
                For col = 1 To 3
                    If col <= UBound(NewData) + 1 Then lastRow.Cells(1, col) = NewData(col - 1)
                Next col
            End With
        End If
    Next i
End With
dSht.Protect Password:="Open"

dSht.Range("A1").Select
ExitHandler:
Application.ScreenUpdating = True
dSht.Protect Password:="Open"
End Sub
 
I'd recommend uploading sample workbook, with few data on each tables. It makes going through your code action so much easier and you'll likely get better help.
 
Thanks Chihiro - for looking into my request.

Here's a sample file with dummy data.

Thanks again.
Regards/Ajesh
 

Attachments

  • SampleWB - CompareLO.xlsm
    22.9 KB · Views: 24
Code looks fine. Only thing is that if data size becomes large, you may experience significant slow down.

With about 1000 items added to sht_Source, took about 30 - 40 sec for code to finish running when 1 item is added to sht_Source and sht_Routes activated after.

How large will your list get? Depending on that, I'd suggest doing comparison operation within Memory (using array and/or dictionary). And only do update operation on tableB after that's been completed.
 
Code looks fine. Only thing is that if data size becomes large, you may experience significant slow down.

With about 1000 items added to sht_Source, took about 30 - 40 sec for code to finish running when 1 item is added to sht_Source and sht_Routes activated after.

How large will your list get? Depending on that, I'd suggest doing comparison operation within Memory (using array and/or dictionary). And only do update operation on tableB after that's been completed.
Thanks @Chihiro for looking into it.

First of all, it's really encouraging when an 'Excel Ninja' says "Code looks fine". I have a lot to learn from you guys here.

Execution time is something that I also noticed and hence posted the code here to seek optimization. The file will be shared with our prospective customers and surely a lagging file will be a turn down for them. No. of records in tables may range from 10-15 to 1500-2000 depending upon the scale of business of respective customers.

Looking forward for you valuable suggestions.

Regards/Ajesh
 
Hi @Chihiro
Is it possible you can help me with the "comparison operation within memory" that you mentioned. I am not sure how to go about it.

thanks/Ajesh
 
Sure. What sort of environment is expected?

Is all users on PC/Windows based environment or is there some that use Mac?
 
To
Sure. What sort of environment is expected?

Is all users on PC/Windows based environment or is there some that use Mac?
To be honest, this will be circulated to prospective clients/customers all over the globe and they can be using any of them - Windows or Mac.

Regards/Ajesh
 
Hmm, that complicates things a bit. Normally I'd do this using array and dictionary objects. Dictionary being one of the fastest way to check if match exists. But Mac doesn't support Scripting.Dictionary.

Of course, I could use VBA Dictionary class module found in link below.
https://github.com/VBA-tools/VBA-Dictionary

However, I've never tested it and avoid Mac like plague :p In majority of cases when I have to implement solution for Mac & PC, I just push data as JASON to IIS server and have it consumed by java (AM Charts and such) or use web front end, rather than Excel.

Let me mull it over a bit and see what I come up with.
 
Hi !

All Dictionary behaviour can be reproduced using a Collection class module
and even improved !
I published a sample in a local forum but there are many on Web …
 
All Dictionary behaviour can be reproduced using a Collection class module
and even improved !
Not sure what you mean. Can you elaborate?

At any rate, I'm thinking this one can be done using array only.

In standard module.
Code:
Sub DataConsolidate()
Dim sA, rA, x
Dim tempS, tempR(), resA
Dim i As Long, j As Long, k As Long
Dim mstr As String

sA = ThisWorkbook.Sheets(1).ListObjects(1).DataBodyRange.Value
With ThisWorkbook.Sheets(2)
    .Unprotect Password:="Open"
    With .ListObjects(1)
        rA = .DataBodyRange.Value
        .DataBodyRange.Delete
    End With
End With

ReDim tempS(1 To UBound(sA))
For i = 1 To UBound(sA)
    tempS(i) = Join(Array(sA(i, 1), sA(i, 3), sA(i, 5)), ",")
Next
For i = 1 To UBound(rA)
    mstr = Join(Array(rA(i, 1), rA(i, 2), rA(i, 3)), ",")
    x = Application.Match(mstr, tempS, 0)
    If IsNumeric(x) Then
        j = j + 1
        ReDim Preserve tempR(j)
        tempR(j - 1) = Join(Array(mstr, rA(i, 4), rA(i, 5), rA(i, 6)), ",")
    End If
Next
For i = 1 To UBound(tempS)
    x = Application.Match(tempS(i) & "*", tempR, 0)
    If IsError(x) Then
        j = j + 1
        ReDim Preserve tempR(j)
        tempR(j - 1) = tempS(i)
    End If
Next
ReDim resA(UBound(tempR), 6)
For i = 0 To UBound(tempR)
    x = Split(tempR(i), ",")
    For k = 0 To UBound(x)
        resA(i, k) = x(k)
    Next
Next
With ThisWorkbook.Sheets(2)
    .Cells(2, 1).Resize(UBound(resA), UBound(resA, 2)) = resA
    .Protect Password:="Open"
End With
End Sub

Then call it in worksheet module.
Code:
Private Sub Worksheet_Activate()
Call DataConsolidate
End Sub

Edit: @Ajesh test and let me know if any issues.
 
Last edited:
Not sure what you mean. Can you elaborate?
Any Windows Dictionary VBA code can be used as it is
under a MAC VBA code through a classic VBA Collection class module :
same behavior with same Dictionary statements declared in this module …

Example of a classic Windows VBA code from an old post on a local forum :​
Code:
Sub Demo()
                      Dim oDic As Object, C&, L&, R&
    Application.ScreenUpdating = False
                      Set oDic = CreateObject("Scripting.Dictionary")
    With Feuil1.Cells(1).CurrentRegion.Rows
                      C = .Columns.Count + 1
        With .Resize(, C)
              .Columns(C).Value = 1
            For R = 2 To .Count
                If Not oDic.Exists(.Cells(R, 1).Value) Then
                    .Cells(R, C).Value = 0
                    oDic.Add .Cells(R, 1).Value, oDic.Count + 2
                End If
            Next
                .Sort .Cells(C), xlAscending, Header:=xlYes
                .Columns(C).Clear
        End With
        For R = oDic.Count + 2 To .Count
            L = oDic.Item(.Cells(R, 1).Value)
            C = .Cells(L, 1).End(xlToRight).Column + 1
            If .Cells(1, C).Value = "" Then .Item(1).Copy .Cells(1, C)
                .Item(R).Copy .Cells(L, C)
        Next
            .Parent.Rows(oDic.Count + 2 & ":" & .Count).Delete
    End With
                          oDic.RemoveAll
                      Set oDic = Nothing
    Application.ScreenUpdating = True
End Sub
Under a MAC VBA code, once the class module uploaded in the project,
it just needs to mod codeline #2 by replacing
Dim oDic As Object by Dim oDic As New Dictionnaire
- Dictionnaire is the class module Collection entry name as a Dictionary -
and delete codeline #4, that's all !

It was just to say a Windows Dictionary code can be easily adapted on MAC,
keeping same syntax …
Even using an unique code whatever MAC or Windows OS !

Dictionary is just an improved Collection.
Dictionnaire class module is just a Dictionary behavior
improved just using a Collection
 
Ah, got ya. Pretty much the same concept as the link I added in Post #10. Class module to import to add same functionality as Scripting.Dictionary.
 
Not sure what you mean. Can you elaborate?

At any rate, I'm thinking this one can be done using array only.

In standard module.
Code:
Sub DataConsolidate()
Dim sA, rA, x
Dim tempS, tempR(), resA
Dim i As Long, j As Long, k As Long
Dim mstr As String

sA = ThisWorkbook.Sheets(1).ListObjects(1).DataBodyRange.Value
With ThisWorkbook.Sheets(2)
    .Unprotect Password:="Open"
    With .ListObjects(1)
        rA = .DataBodyRange.Value
        .DataBodyRange.Delete
    End With
End With

ReDim tempS(1 To UBound(sA))
For i = 1 To UBound(sA)
    tempS(i) = Join(Array(sA(i, 1), sA(i, 3), sA(i, 5)), ",")
Next
For i = 1 To UBound(rA)
    mstr = Join(Array(rA(i, 1), rA(i, 2), rA(i, 3)), ",")
    x = Application.Match(mstr, tempS, 0)
    If IsNumeric(x) Then
        j = j + 1
        ReDim Preserve tempR(j)
        tempR(j - 1) = Join(Array(mstr, rA(i, 4), rA(i, 5), rA(i, 6)), ",")
    End If
Next
For i = 1 To UBound(tempS)
    x = Application.Match(tempS(i) & "*", tempR, 0)
    If IsError(x) Then
        j = j + 1
        ReDim Preserve tempR(j)
        tempR(j - 1) = tempS(i)
    End If
Next
ReDim resA(UBound(tempR), 6)
For i = 0 To UBound(tempR)
    x = Split(tempR(i), ",")
    For k = 0 To UBound(x)
        resA(i, k) = x(k)
    Next
Next
With ThisWorkbook.Sheets(2)
    .Cells(2, 1).Resize(UBound(resA), UBound(resA, 2)) = resA
    .Protect Password:="Open"
End With
End Sub

Then call it in worksheet module.
Code:
Private Sub Worksheet_Activate()
Call DataConsolidate
End Sub

Edit: @Ajesh test and let me know if any issues.
Many thanks @Chihiro , I will try it and let you know how it goes.

I would also like to thank all others for showing interest and lending a helping hand.

Regards/Ajesh
 
Not sure what you mean. Can you elaborate?

At any rate, I'm thinking this one can be done using array only.

In standard module.
Code:
Sub DataConsolidate()
Dim sA, rA, x
Dim tempS, tempR(), resA
Dim i As Long, j As Long, k As Long
Dim mstr As String

sA = ThisWorkbook.Sheets(1).ListObjects(1).DataBodyRange.Value
With ThisWorkbook.Sheets(2)
    .Unprotect Password:="Open"
    With .ListObjects(1)
        rA = .DataBodyRange.Value
        .DataBodyRange.Delete
    End With
End With

ReDim tempS(1 To UBound(sA))
For i = 1 To UBound(sA)
    tempS(i) = Join(Array(sA(i, 1), sA(i, 3), sA(i, 5)), ",")
Next
For i = 1 To UBound(rA)
    mstr = Join(Array(rA(i, 1), rA(i, 2), rA(i, 3)), ",")
    x = Application.Match(mstr, tempS, 0)
    If IsNumeric(x) Then
        j = j + 1
        ReDim Preserve tempR(j)
        tempR(j - 1) = Join(Array(mstr, rA(i, 4), rA(i, 5), rA(i, 6)), ",")
    End If
Next
For i = 1 To UBound(tempS)
    x = Application.Match(tempS(i) & "*", tempR, 0)
    If IsError(x) Then
        j = j + 1
        ReDim Preserve tempR(j)
        tempR(j - 1) = tempS(i)
    End If
Next
ReDim resA(UBound(tempR), 6)
For i = 0 To UBound(tempR)
    x = Split(tempR(i), ",")
    For k = 0 To UBound(x)
        resA(i, k) = x(k)
    Next
Next
With ThisWorkbook.Sheets(2)
    .Cells(2, 1).Resize(UBound(resA), UBound(resA, 2)) = resA
    .Protect Password:="Open"
End With
End Sub

Then call it in worksheet module.
Code:
Private Sub Worksheet_Activate()
Call DataConsolidate
End Sub

Edit: @Ajesh test and let me know if any issues.
You are a genius @Chihiro. It worked like a charm and fast as Flash. Though the code is above my "Understanding Level" :p but I was able to modify it to my needs (No. of columns and their sequence etc.):awesome: Learning day by day. :)

Thanks a ton!!!

Regards/Ajesh
 
Back
Top