Transpose Filtered Column As String to Cell

Question

I have a table which looks like this:

I wrote code which gives output like this:

The goal is a results table which does the following:

• Count number of times "old" status appears
• Count numer of times "new" status appears
• Get all the (unique) old groups in one cell
• Get all the (unique) new groups in one cell

The following code worked on one computer but not on another (both Windows, 64bit):

Sub TableSummary()
    Dim sht As Worksheet
    Dim i As Integer
    Dim tbl As ListObject
    Dim new_tbl As ListObject, old_tbl As ListObject
    Dim new_array As Variant, old_array As Variant
    
    '2. Disable Screen Updating - stop screen flickering and Disable Events to avoid inturupted dialogs / popups
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Application.DisplayAlerts = False
    On Error Resume Next
    Application.DisplayAlerts = True
    
    '4. Add a new summary table to summary worksheet
    With ActiveWorkbook
        sht.ListObjects.Add(xlSrcRange, sht.UsedRange, , xlYes).Name = "Summary"
        sht.ListObjects("Summary").TableStyle = "TableStyleMedium5"
    End With

    i = 1
    For Each sht In ActiveWorkbook.Worksheets
        If sht.Name = "Summary" Then
            'Define Column Headers of Summary
            sht.Cells(1, 4).Resize(1, 4).Value = Array("Nbr of old", "Nbr of new", "Groups old", "Groups new")
        
            i = i + 1
            
            For Each tbl In sht.ListObjects
                ' Blue table
                If tbl.TableStyle = "TableStyleMedium2" Then
                    sht.Range("D" & i).Value = WorksheetFunction.CountIf(tbl.Range, "old")
                    sht.Range("E" & i).Value = WorksheetFunction.CountIf(tbl.Range, "new")
        
                    Set new_tbl = sht.ListObjects("Summary")
                    Set new_tbl = sht.ListObjects("Summary").Range().AutoFilter(Field:=2, Criteria1:="old")
                    new_array = Application.Transpose(WorksheetFunction.Unique(sht.ListObjects("Summary").ListColumns("Group").DataBodyRange.SpecialCells(xlCellTypeVisible))) 'This doesn't work on my other machine
                    sht.Range("F" & i).Value = Join(new_array, ", ") 'works!
                    'Debug.Print Join(new_array, ", ")
        
                    sht.ListObjects("Summary").AutoFilter.ShowAllData
                    Set new_tbl = sht.ListObjects("Summary")
                    Set new_tbl = sht.ListObjects("Summary").Range().AutoFilter(Field:=2, Criteria1:="new")
                    new_array = Application.Transpose(WorksheetFunction.Unique(sht.ListObjects("Summary").ListColumns("Group").DataBodyRange.SpecialCells(xlCellTypeVisible))) 'This doesn't work on my other machine
                    sht.Range("G" & i).Value = Join(new_array, ", ") 'works!
                    Debug.Print Join(new_array, ", ")
        
                    sht.ListObjects("Summary").AutoFilter.ShowAllData
                    
                End If
            Next
        End If
    Next
End Sub

Application.Transpose does not work on my second machine.

Answer 1

Here's a different approach using a function to create the list of unique values:

Sub TableSummary()
    Const NEW_OLD_COL As Long = 2
    Const GROUP_COL As String = "Group"
    Const VAL_OLD As String = "old"
    Const VAL_NEW As String = "new"
    
    Dim sht As Worksheet, DstSht As Worksheet
    Dim i As Integer
    Dim tbl As ListObject
    Dim new_tbl As ListObject, old_tbl As ListObject
    Dim new_array As Variant, old_array As Variant
    
    Set sht = ActiveSheet 'or whatever...
    Set DstSht = sht
    i = 2
    
    For Each tbl In sht.ListObjects
        ' Blue table
        If tbl.TableStyle = "TableStyleMedium2" Then
            
            With tbl.ListColumns(NEW_OLD_COL)
                DstSht.Range("G" & i).Value = WorksheetFunction.CountIf(.DataBodyRange, VAL_OLD)
                DstSht.Range("H" & i).Value = WorksheetFunction.CountIf(.DataBodyRange, VAL_NEW)
            End With
            
            tbl.Range.AutoFilter Field:=NEW_OLD_COL, Criteria1:="new"
            DstSht.Range("I" & i).Value = VisibleUniques(tbl, GROUP_COL)
            tbl.Range.AutoFilter
    
            tbl.Range.AutoFilter Field:=NEW_OLD_COL, Criteria1:="old"
            DstSht.Range("J" & i).Value = VisibleUniques(tbl, GROUP_COL)
            tbl.Range.AutoFilter
            i = i + 1
        End If
    Next
End Sub

'Return a comma-separated list of all unique values in visible cells in 
'   column `ColName` of listobject `tbl`
Function VisibleUniques(tbl As ListObject, ColName As String) As String
    Dim rngVis As Range, dict As Object, c As Range
    On Error Resume Next 'ignore error if no visible cells
    Set rngVis = tbl.ListColumns(ColName).DataBodyRange.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0      'stop ignoring errors
    If rngVis Is Nothing Then Exit Function
    Set dict = CreateObject("scripting.dictionary")
    For Each c In rngVis.Cells
        dict(CStr(c.Value)) = True
    Next c
    VisibleUniques = Join(dict.keys, ", ")
End Function