VBA - generate a new table based on conditional values in an existing table

[g00ber]

Hello,

I would like to use VBA to generate a new table (see bottom screenshot) based on the values in an existing table(see top screenshot).

The new table should include a count for each month that contains a value of "Red" and the "Person(s)" for which this applies. This would need to be updated by clicking a button to refresh the data in the new table.

Thank you

[#2]

@g00ber 

To generate a new table based on conditional values in an existing table using VBA, you can use the following steps:

1. Open your Excel workbook and press Alt + F11 to open the VBA editor.
2. In the VBA editor, click on Insert and then click on Module.
3. In the new module window, paste the following code:

Untested, needs to be adapted to your spreadsheets.

Sub GenerateTable()
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim rng As Range
    Dim dict As Object
    Dim i As Long
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set tbl = ws.ListObjects("Table1")
    Set rng = tbl.ListColumns("Month").DataBodyRange
    
    Set dict = CreateObject("Scripting.Dictionary")
    
    For i = 1 To rng.Rows.Count
        If tbl.DataBodyRange(i, 2) = "Red" Then
            If Not dict.Exists(rng(i)) Then
                dict.Add rng(i), New Collection
            End If
            
            dict(rng(i)).Add tbl.DataBodyRange(i, 1)
        End If
    Next i
    
    Set rng = ws.Range("A1").Resize(dict.Count + 1, 2)
    
    rng(1, 1) = "Month"
    rng(1, 2) = "Person(s)"
    
    i = 2
    
    For Each key In dict.Keys
        rng(i, 1) = key
        rng(i, 2) = Join(CollectionToArray(dict(key)), ", ")
        i = i + 1
    Next key
    
End Sub

Function CollectionToArray(col As Collection) As Variant()
    Dim arr() As Variant
    Dim i As Long
    
    ReDim arr(col.Count - 1)
    
    For i = 0 To col.Count - 1
        arr(i) = col.Item(i + 1)
    Next i
    
    CollectionToArray = arr
End Function

VBA code, sometime from the internet, no idea where long ago.

4. Replace "Sheet1" with your sheet name and "Table1" with your table name.

5. Save your workbook as a macro-enabled workbook

6. Press Alt + F8 to open the Macro dialog box

7. Select GenerateTable and click on Run.

8. The new table will be generated with a count for each month that contains a value of “Red” and the “Person(s)” for which this applies.

9. You can update this table by clicking a button to refresh the data in the new table.

I hope this helps!

[#3]

@g00ber 

An alternative. It assumes that you already created the target sheet, with column headers in A1:C1.

Sub UpdateOutput()
    Const red = 192     ' Red color used - check your sheet
    Dim ws As Worksheet ' Source sheet
    Dim s As Long       ' Row number on source sheet
    Dim m As Long       ' Max row number on source sheet
    Dim c As Long       ' Column number on source sheet
    Dim n As Long       ' Max column number on source sheet
    Dim r As Long       ' Count of red cells in column on source sheet
    Dim p As String     ' Person names on source sheet
    Dim wt As Worksheet ' Target sheet
    Dim t As Long       ' Row number on target sheet
    Application.ScreenUpdating = False
    Set ws = Worksheets("Sheet1")
    m = ws.Cells(1, 1).End(xlDown).Row
    n = ws.Cells(1, 1).End(xlToRight).Column
    Set wt = Worksheets("Sheet2")
    wt.Range("A2:C1000").Clear
    t = 1
    For c = 2 To n
        r = 0
        p = ""
        For s = 2 To m
            If ws.Cells(s, c).Interior.Color = red Then
                r = r + 1
                p = p & vbLf & ws.Cells(s, 1).Value
            End If
        Next s
        If r > 0 Then
            t = t + 1
            wt.Cells(t, 1).Value = ws.Cells(1, c).Value
            wt.Cells(t, 2).Value = r
            wt.Cells(t, 3).Value = Mid(p, 2)
        End If
    Next c
    wt.Cells(2, 1).Resize(t - 1).NumberFormat = "mmm-yy"
    wt.Cells(2, 3).Resize(t - 1).WrapText = True
    Application.ScreenUpdating = True
End Sub