I have a table which looks like this
Now I wrote a code which gives me an output like this:
So the goal is to have a results tabel 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
I have tried the following code, which worked on one computer, but does not on my other one (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 and I have absolutely no idea why. If anyone can help me with this, it would be very, very much appreciated!
CodePudding user response:
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 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