Help: Table with multiple values to List

[Xerno]

Hi everyone,

Im trying to figure out a way to make a Table into a list.

Example:

[TABLE="class: grid, width: 500, align: center"]
<tbody>[TR]
[TD][/TD]
[TD]Peter[/TD]
[TD]Anders[/TD]
[TD]Mikael[/TD]
[TD]John[/TD]
[/TR]
[TR]
[TD]Criteria1[/TD]
[TD]1[/TD]
[TD][/TD]
[TD]1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Criteria2[/TD]
[TD][/TD]
[TD]1[/TD]
[TD][/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]Criteria3[/TD]
[TD]1[/TD]
[TD]1[/TD]
[TD]1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Criteria4[/TD]
[TD][/TD]
[TD]1[/TD]
[TD][/TD]
[TD]1[/TD]
[/TR]
</tbody>[/TABLE]


What I know want to do is the following if the cell has "1" with a formula if possible:

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Peter[/TD]
[TD]Criteria1[/TD]
[/TR]
[TR]
[TD]Peter[/TD]
[TD]Criteria3[/TD]
[/TR]
[TR]
[TD]Anders[/TD]
[TD]Criteria2[/TD]
[/TR]
[TR]
[TD]Anders[/TD]
[TD]Criteria3[/TD]
[/TR]
[TR]
[TD]Anders[/TD]
[TD]Criteria4[/TD]
[/TR]
[TR]
[TD]Mikael[/TD]
[TD]Criteria1[/TD]
[/TR]
[TR]
[TD]Mikael[/TD]
[TD]Criteria3[/TD]
[/TR]
[TR]
[TD]John[/TD]
[TD]Criteria2[/TD]
[/TR]
[TR]
[TD]John[/TD]
[TD]Criteria4[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

I was first thinking with a Index Match but I cant figure this out.

Can anyone help me?

Thanks in advance

 

[Takae]

Sheet1 has data, results will be in Sheet2.

Sub test()
Dim cnt As Long, i As Long, j As Long, LR As Long
Dim rng As Range, c
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
With ws1
    For i = 2 To .cells(1, Columns.count).End(xlToLeft).column
        .Range("A1").AutoFilter field:=i, Criteria1:=1
        If WorksheetFunction.Subtotal(3, .Range("A:A")) > 1 Then
            For Each c In .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible)
                If c <> "" Then
                    With ws2
                        LR = .cells(Rows.count, 1).End(xlUp).row + 1
                        .cells(LR, 2).Value = c.value
                        .cells(LR, 1).Value = ws1.cells(1, i).Value
                    End With
                End If
            Next
        End If
        .Range("A1").AutoFilter
    Next
End With
End Sub

 

[Xerno]

Thank you so much, works like a charm

Arigatō sensei