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]

Working file: HERE

From what you said, it's the connection string. It's not allowing you to create a db connection to the file. That came from ConnectionStrings.com - Forgot that connection string? Get it here! Always worked for me.

strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & oWb.FullName & "';Extended Properties='Excel 12.0 Macro;HDR=YES;IMEX=0';"

If you type ?strConn in the immediate window, the line above should return a line like below ... with a c:\ file path.

Provider=Microsoft.ACE.OLEDB.12.0;Data Source='C:\Users\Skippy\Desktop\Mr Excel Stuff.xlsm';Extended Properties='Excel 12.0 Macro;HDR=YES;IMEX=0';

If it doesn't work, it's back to manipulting ListObjects.

 

[SimpleMan618]

Working file: HERE

From what you said, it's the connection string. It's not allowing you to create a db connection to the file. That came from ConnectionStrings.com - Forgot that connection string? Get it here! Always worked for me.

strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & oWb.FullName & "';Extended Properties='Excel 12.0 Macro;HDR=YES;IMEX=0';"

If you type ?strConn in the immediate window, the line above should return a line like below ... with a c:\ file path.

Provider=Microsoft.ACE.OLEDB.12.0;Data Source='C:\Users\Skippy\Desktop\Mr Excel Stuff.xlsm';Extended Properties='Excel 12.0 Macro;HDR=YES;IMEX=0';

If it doesn't work, it's back to manipulating ListObjects.

I downloaded your workbook and the code works as expected. I then copied it over to a new workbook and it errored out again. I realized that when I created the local version of it, I saved it in documents which is backed up to OneDrive, so I moved my workbook to downloads and found the code working as expected.

The code doesn't work when the workbook is on a shared drive (I tried it on a sharepoint as well).

With that being said, would you recommend using the code you provided first and then adding the new items into the other tables? Thank you so much for your help and troubleshooting on this.

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