Compare two Tables, Find Unique values and add unique as new row to a third

[SimpleMan618]

I have a complex workbook that has many users active in it. I need help with troubleshooting a VBA, however I have never used Dictionary before, so it's been a 5-day nightmare. (Maybe there is another way to solve my problem, but I am still learning VBA and couldn't find a good answer in my searches)

My problem is that the admin will add new "sports" to the Table page. The problem with that is many of the other reference sheets that have the sports listed are manually copied onto their own table. I tried to automate that but with the duplicates on the Table sheet and the users' changing views or sorting, it was messing with the manual entries that they were entering. I believe the solution is to compare the two tables I have (Both on Data sheet which came from the Table and Calendar sheets) and add a row to the tables on the 2023 School Year Updates and Calendar for each unique value that was found.

Here is a mockup of the workbook with mock data and sheet names
I have four sheets

1. Calendar - Which shows a modified Gnatt view. This has the sports as manual.
2. 2023 School Year Updates - Which is where users will update items with Status Updates and notes
3. Table - Which is where the Master Table lives. The Sport will show up multiple times in this sheet and this is where the Admin will add a new sport
4. Data - This sheet is veryhidden and only used to populate other areas of the workbook but I was using it based on the VBA.

The VBA code I am using seems to work but brings up a subscript out of range error when there is a unique value and when there isn't. I have also gotten a type mismatch if there are more than two unique values that need to be entered.

Bottom line, I need a way to update the tables on Calendar and 2023 School Year Updates. Those tables are manually updated because users were changing views and sorting the table which caused misalignment of the statuses and notes among other things. If there is a better way to solve my problem, please let me know. As a reminder, the Mock workbook is just a fraction of the actual workbook. Thank you in advance.

Here is the VBA I was using

Sub UpdateWorkstreams()
Dim Dict As Object 'Scripting.Dictionary
  Dim Where As Range, This As Range
  Dim Item, Items, Counts, Result
  Dim i As Long, j As Long
  Dim Table1 As ListObject
  Dim Table2 As ListObject
  Dim AddedRow1 As ListRow
  Dim AddedRow2 As ListRow
  Dim rngSrc As Range
  
  Set Table1 = Sheets("Calendar").ListObjects("Calendar")
  Set Table2 = Sheets("2023 School Year Updates").ListObjects("SchYr2023")
  Set rngSrc = Sheets("Data").Range("G2:G31")
  rngSrc.ClearContents

  'Step 1: Collect all items

  'Create a dictionary to collect unique items
  Set Dict = CreateObject("Scripting.Dictionary")
  'Ignore spelling
  Dict.CompareMode = vbTextCompare

  'Refer to the used cells in column A in Sheet1
  With Sheets("Data")
    Set Where = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
  End With
  'Collect the items
  GoSub CollectItems

  'Refer to the used cells in column C in Sheet2
  With Sheets("Data")
    Set Where = .Range("E2", .Range("E" & Rows.Count).End(xlUp))
  End With
  'Collect the items
  GoSub CollectItems

  'Step 2: Sort out the duplicates

  'Get all items and counts
  Items = Dict.Keys
  Counts = Dict.Items

  'Count all items which occurs only one time
  j = 0
  For i = 0 To UBound(Counts)
    If Counts(i) = 1 Then j = j + 1
  Next


  'Step 3: Output

  'Create an array for the output
  ReDim Result(1 To j, 1 To 1)
  'Fill in the items
  j = 0
  For i = 0 To UBound(Counts)
    If Counts(i) = 1 Then
      j = j + 1
      Result(j, 1) = Items(i)
    End If
  Next

  'Flush into Sheet3
  With Sheets("Data")
    .Range("G2").Resize(UBound(Result)).Value = Result
  End With
 

Set AddedRow1 = Table1.ListRows.Add()
    With AddedRow1.Range(1) = Result
End With

  'Done
  Exit Sub
CollectItems:
  'Each cell
  For Each This In Where
    'The compare key is the value
    Item = This.Value
    'Already found?
    If Not Dict.Exists(Item) Then
      'No, add to the dictionary
      Dict.Add Item, 1
    Else
      'Yes, increase the number of occurences
      Dict(Item) = Dict(Item) + 1
    End If
  Next
  Return
End Sub

 

[mmhill]

A different strategy than the dictionary.

This converts the Calendar list to a deliminated string (e.g., "Baseball|Football|Soccer"). Goes thru sports on Data list and looks for them in the deliminated string. If they NOT are found the sport is saved a unique by building a deliminated string of unique sports. Once we go thru all sports on the data list, if there are still sports left in the calendar string, they MUST be unique and are added to the unique sports list.

This way only needs ot make one pass thru the list.

There is other code to deal with blank spaces in the middle of a list and in case either list has a sport listed moe than once (it only shows up on the unique list once) The Transpose function moves form a vertical array (one column, many rows) to horizontal (one row, many columns) (this is how VBA see arrays)

All your items were in tables, so I used that. Makes reference easy and the range will expand automatically as the tables do.

make sure all range and sheet names are what you want.

Option Explicit
Sub UpdateWorkstreams()
Dim aySportList, ayCalendarList, strCalendarList$
Dim Sport, strUsed$, strUnique$, ayUnique

    'crete an array of sports from tables. convert calendar list to a deliminated string
    aySportList = Application.Transpose(Sheet9.ListObjects("DATA").ListColumns("Sport").DataBodyRange)
    ayCalendarList = Application.Transpose(Sheet9.ListObjects("Table6").ListColumns("Compare List from Calendar").DataBodyRange)
    strCalendarList = Join(ayCalendarList, "|") & "|"

    'Look for sport in calendar deliminated string
    'this gives a list of all sports IN data but not in Calendar
    For Each Sport In aySportList
        Select Case True 'pick teh case that is true
            Case InStr(1, strUsed, Sport, vbTextCompare) > 0 'if we already saw this sport, do nothing; i.e., on data list twice
            Case Sport <> "" And InStr(1, strCalendarList, Sport, vbTextCompare) = 0 'if not empty and not in calendar, add to unique list
                strUnique = strUnique & Sport & "|"
            Case Sport <> "" 'if sport not blank take it off the calendar string
                strCalendarList = Replace(strCalendarList, Sport & "|", "")
        End Select
        strUsed = strUsed & Sport & "|" 'trim last character
    Next Sport

    If Len(Replace(strCalendarList, "|", "")) > 0 Then ' if there are items on the calndar list besides deliminator (eg sport on calendar but not on data list
   
        ayCalendarList = Split(strCalendarList, "|") 'split the calendar list to an array
       
        For Each Sport In ayCalendarList
            If Sport <> "" And InStr(1, strUsed, Sport, vbTextCompare) = 0 Then 'if sport not "" and not on unique list , put it there
                strUnique = strUnique & Sport & "|"
                strUsed = strUsed & Sport & "|" 'add to the used list
            End If
        Next Sport
   
    End If

    'put values into the spread sheet
    strUnique = Left(strUnique, Len(strUnique) - 1)
    ayUnique = Application.Transpose(Split(strUnique, "|"))
    With Sheet9.Range("$G2")
        .CurrentRegion.Offset(1, 0).ClearContents
        .Resize(UBound(ayUnique)) = ayUnique
    End With

End Sub

 

[SimpleMan618]

A different strategy than the dictionary.

This converts the Calendar list to a deliminated string (e.g., "Baseball|Football|Soccer"). Goes thru sports on Data list and looks for them in the deliminated string. If they NOT are found the sport is saved a unique by building a deliminated string of unique sports. Once we go thru all sports on the data list, if there are still sports left in the calendar string, they MUST be unique and are added to the unique sports list.

This way only needs ot make one pass thru the list.

There is other code to deal with blank spaces in the middle of a list and in case either list has a sport listed moe than once (it only shows up on the unique list once) The Transpose function moves form a vertical array (one column, many rows) to horizontal (one row, many columns) (this is how VBA see arrays)

All your items were in tables, so I used that. Makes reference easy and the range will expand automatically as the tables do.

make sure all range and sheet names are what you want.

Option Explicit
Sub UpdateWorkstreams()
Dim aySportList, ayCalendarList, strCalendarList$
Dim Sport, strUsed$, strUnique$, ayUnique

    'crete an array of sports from tables. convert calendar list to a deliminated string
    aySportList = Application.Transpose(Sheet9.ListObjects("DATA").ListColumns("Sport").DataBodyRange)
    ayCalendarList = Application.Transpose(Sheet9.ListObjects("Table6").ListColumns("Compare List from Calendar").DataBodyRange)
    strCalendarList = Join(ayCalendarList, "|") & "|"

    'Look for sport in calendar deliminated string
    'this gives a list of all sports IN data but not in Calendar
    For Each Sport In aySportList
        Select Case True 'pick teh case that is true
            Case InStr(1, strUsed, Sport, vbTextCompare) > 0 'if we already saw this sport, do nothing; i.e., on data list twice
            Case Sport <> "" And InStr(1, strCalendarList, Sport, vbTextCompare) = 0 'if not empty and not in calendar, add to unique list
                strUnique = strUnique & Sport & "|"
            Case Sport <> "" 'if sport not blank take it off the calendar string
                strCalendarList = Replace(strCalendarList, Sport & "|", "")
        End Select
        strUsed = strUsed & Sport & "|" 'trim last character
    Next Sport

    If Len(Replace(strCalendarList, "|", "")) > 0 Then ' if there are items on the calndar list besides deliminator (eg sport on calendar but not on data list
  
        ayCalendarList = Split(strCalendarList, "|") 'split the calendar list to an array
      
        For Each Sport In ayCalendarList
            If Sport <> "" And InStr(1, strUsed, Sport, vbTextCompare) = 0 Then 'if sport not "" and not on unique list , put it there
                strUnique = strUnique & Sport & "|"
                strUsed = strUsed & Sport & "|" 'add to the used list
            End If
        Next Sport
  
    End If

    'put values into the spread sheet
    strUnique = Left(strUnique, Len(strUnique) - 1)
    ayUnique = Application.Transpose(Split(strUnique, "|"))
    With Sheet9.Range("$G2")
        .CurrentRegion.Offset(1, 0).ClearContents
        .Resize(UBound(ayUnique)) = ayUnique
    End With

End Sub

Thank you *mmhill. This works great and I didn't think of doing that. The last piece of the puzzle is to add each unique item to the manual tables on the other sheets. Thank you again.

 

[mmhill]

I believe the solution is to compare the two tables I have (Both on Data sheet which came from the Table and Calendar sheets) and add a row to the tables on the 2023 School Year Updates and Calendar for each unique value that
was found.

So, your goal is to just get new sports from the TABLE sheet into the Calendar sheet and 2023 School Year sheet? Is the DATA sheet necessary to sync also or you were using it as tool for updates? The DATA sheet is not necessary to keep TABLE, Calendar and 2023 in sync.

Is the only place a sport will be added the TABLE sheet? Meaning, all new sport names will start in TABLE and be placed into the Calendar and 2023 sheets and never the other way around? I understand it is possible that a new sport could be added to TABLE and then someone might manually add it to Calendar but not 2023 ... or to 2023 and not Calendar. The goal, then, is to have every sport in TABLE show up in both Calendar (once) and in 2023 (once), correct?

Is there risk that there will be blank cells or rows in the lists? Do you want the Canendar and 2023 tables sorted some way after adding new rows?

 

[SimpleMan618]

So, your goal is to just get new sports from the TABLE sheet into the Calendar sheet and 2023 School Year sheet? Is the DATA sheet necessary to sync also or you were using it as tool for updates? The DATA sheet is not necessary to keep TABLE, Calendar and 2023 in sync.

Is the only place a sport will be added the TABLE sheet? Meaning, all new sport names will start in TABLE and be placed into the Calendar and 2023 sheets and never the other way around? I understand it is possible that a new sport could be added to TABLE and then someone might manually add it to Calendar but not 2023 ... or to 2023 and not Calendar. The goal, then, is to have every sport in TABLE show up in both Calendar (once) and in 2023 (once), correct?

Is there risk that there will be blank cells or rows in the lists? Do you want the Canendar and 2023 tables sorted some way after adding new rows?

Hi *mmhill
Thanks for the reply.

The goal is just to update the Calendar sheet and the 2023 School Year sheet with the sports from the Table sheet (Just one instance of it). The Data sheet is hidden and only used for certain data collection and non-visible data that is used throughout the workbook. This made me think that there could be a scenario where a sport is removed from the table sheet, and we would need to make that change to the Calendar and 2023 sheets.

The only place that a sport can be added is the Table sheet by the admin. There is no other place where it can be added. The other sheets are protected where the sports are located. (Which I can add the unprotect/protect script within the code to get around).

The goal, then, is to have every sport in TABLE show up in both Calendar (once) and in 2023 (once), correct? That is correct.

Is there risk that there will be blank cells or rows in the lists? There shouldn't be, but the admin could make a mistake and leave a blank row.

Do you want the Calendar and 2023 tables sorted some way after adding new rows? Alphabetically, is the ideal sort.

 

[mmhill]

OK. Given what you want to do, a different, more direct approach.

For adding new sports, we treat the 3 tables like a database and insert new Sports from the Master table that do not exist in the Calendar and Updates tables into those tables. Then we sort all tables alphabetically by sport (first). Then, we compare all sports in the Calendar and Update tables to the Master. If we find sports NOT in the master, we delete those rows.

IMPORTANT - Change the table name of the "Calendar" table. For some reason, VBA an SQL does not like that name and errored every time. I used "SportCalendar" and it worked fine.

Option Explicit

Sub PopTables()
Dim oWb As Workbook
Dim tblMaster As ListObject, tblCalendar As ListObject, tblUpdates As ListObject
Dim dbConn As Object, strConn$, strSQL$  'http://www.connectionstrings.com
Dim strSports$, tmpItem, i%

    'set object variables for all listobjects we need
    Set oWb = ThisWorkbook
    Set tblMaster = Sheet1.ListObjects("Master_Table")
    Set tblCalendar = Sheet3.ListObjects("SportCalendar")
    Set tblUpdates = Sheet4.ListObjects("SchYr2023")
    
    'add names to the workbook for each list object; overwrites old names
    With oWb
        .Names.Add "tblMaster", tblMaster.Range, True
        .Names.Add "tblCalendar", tblCalendar.Range, True
        .Names.Add "tblUpdates", tblUpdates.Range, True
    End With
    
    'open a database connection
    Set dbConn = CreateObject("ADODB.Connection")
    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & oWb.FullName & "';Extended Properties='Excel 12.0 Macro;HDR=YES;IMEX=0';"
    dbConn.Open strConn
    
    'SQL to update calendar for new items in master table
    strSQL = "INSERT into tblCalendar SELECT DISTINCT m.Sport from tblMaster as m where m.Sport not in (SELECT Sport from tblCalendar) ORDER BY m.Sport;"
    dbConn.Execute strSQL
    
    'SQL to update updates for new items in master table
    strSQL = "INSERT into tblUpdates SELECT DISTINCT m.Sport from tblMaster as m where m.Sport not in (SELECT Sport from tblUpdates) ORDER BY m.Sport;"
    dbConn.Execute strSQL
        
    'sort all the tables; see function below
    Call psSortTables
    
    'make a deliminated string of the Master data table sports
    strSports = Join(Application.Transpose(Range(tblMaster.Name & "[Sport]")), "|")

    'look at the rows in Caledar and Updates ... delete rows where the sport is not in the Master data list
    For Each tmpItem In Array(tblCalendar, tblUpdates)
        With tmpItem
            For i = .ListRows.Count To 1 Step -1
                If InStr(1, strSports, .ListColumns("Sport").DataBodyRange(i)) = 0 Then .ListRows(i).Delete
            Next i
        End With
    Next

CleanUp:

    If dbConn.State <> 0 Then dbConn.Close
    Set dbConn = Nothing
    Set tblCalendar = Nothing
    Set tblMaster = Nothing
    Set tblUpdates = Nothing
    Set oWb = Nothing
    
End Sub

    Private Sub psSortTables()
    Dim TableToSort As ListObject
    
        Set TableToSort = Sheet1.ListObjects("Master_Table")
        With TableToSort.Sort.SortFields
            .Clear
            .Add2 Key:=Range("Master_Table[Sport]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add2 Key:=Range("Master_Table[Key Dates]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        End With
        GoSub DoSort
        
        Set TableToSort = Sheet4.ListObjects("SchYr2023")
        With TableToSort.Sort.SortFields
            .Clear
            .Add2 Key:=Range("SchYr2023[Sport]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add2 Key:=Range("SchYr2023[Status]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        End With
        GoSub DoSort
        
        Set TableToSort = Sheet3.ListObjects("SportCalendar")
        With TableToSort.Sort.SortFields
            .Clear
            .Add2 Key:=Range("SportCalendar[Sport]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        End With
        GoSub DoSort
    
    Exit Sub
DoSort:
        With TableToSort.Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        Return
    End Sub

 

[mmhill]

I didn't say why I used a loop to delete the records rather than a DELETE SQL instruction. Excel will not allow a DELETE on a linked/dynamic table.

 

[SimpleMan618]

I didn't say why I used a loop to delete the records rather than a DELETE SQL instruction. Excel will not allow a DELETE on a linked/dynamic table.

Thank you *mmhill, that makes sense. I ran the code however; I am getting a "Cannot update. Database or object is read-only." error. I have changed the Calendar table to SportCalendar to match as well.

Here is the break point. I did some quick searching and added the Microsoft ActiveX Data Objects 2.8 to the references but the error continued. Thoughts? Thank you again for your help.

 'open a database connection
    Set dbConn = CreateObject("ADODB.Connection")
    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & oWb.FullName & "';Extended Properties='Excel 12.0 Macro;HDR=YES;IMEX=0';"
    dbConn.Open strConn

 

[mmhill]

I hate when it runs for me but not on another machine. That connection string should work for all Excel beyond 2007.

First, I assumed the macros were in the same workbook as the tables that we are updating. oWb.Fullname should give you that.
Nest, and I don't if this will help or not, try "Excel 12.0 Xml" instead of "Excel 12.0 Macro". If it doesn't help, change it back.
Second, I read that changing the string to "IMEX=1" might help. This tells the database to treat all data as text.
Third, you mentioned that there was protection turned on for some of these pages. Did you turn that off?
Fourth, did you happen to open in read only mode?

Is the file on your computer locally or is it on something like OneDrive? I searched here and trying to work with a OneDrive file gave this error to some people. If that's the case, it's back to doing a loop. I think.

I made a new sample notebook of those few sheets and simple data. You might want to try that. Then it will be clear if it is an Excel/Applicaton/Computer thing or something in the spreadsheet itself.

 

[SimpleMan618]

I hate when it runs for me but not on another machine. That connection string should work for all Excel beyond 2007.

First, I assumed the macros were in the same workbook as the tables that we are updating. oWb.Fullname should give you that.
Nest, and I don't if this will help or not, try "Excel 12.0 Xml" instead of "Excel 12.0 Macro". If it doesn't help, change it back.
Second, I read that changing the string to "IMEX=1" might help. This tells the database to treat all data as text.
Third, you mentioned that there was protection turned on for some of these pages. Did you turn that off?
Fourth, did you happen to open in read only mode?

Is the file on your computer locally or is it on something like OneDrive? I searched here and trying to work with a OneDrive file gave this error to some people. If that's the case, it's back to doing a loop. I think.

I made a new sample notebook of those few sheets and simple data. You might want to try that. Then it will be clear if it is an Excel/Applicaton/Computer thing or something in the spreadsheet itself.

It's the same workbook that I shared. I have yet to move it over to the actual workbook which has the protected sheets. This workbook is not protected in any way. The workbook is currently saved on my personal OneDrive, and it is not in read-only mode. The actual file will be saved on a Sharepoint so the rest of the team can work with it. I copied the file to my local machine, then created a new file with similar data and both got the same errors below. Is it possible for you to send me your sample workbook so I can see if its restrictions applied by our IT?

I changed the Excel 12.0 Macro to Xml and it provided the same error.

I changed that back to Macro and changed the IMEX to 1, and got a different error. "Method 'Open' of object'_connection' failed" at that same spot which is the line below.

dbConn.Open strConn