Excel Transpose duplicate name for every criteria

[Fimpass]

Hi all.

I got a question regarding a file that I'm working on since yesterday.
I got this table:

I need the data to be like this:

So If a person has 3 OK's The code needs to return the column header and create a duplicate for every column header. I got this code now.

Sub BlankLine()Dim Col As Variant, coll As Long, LastRow As Long, i As Long, j As Long, StartRow As Long, LR2 As Long


        Col = "a"
        StartRow = 1




LastRow = Sheet1.Cells(Rows.Count, Col).End(xlUp).Row


Application.ScreenUpdating = False
With ActiveSheet
j = 0
s = 1


For i = 2 To LastRow
 LR2 = Sheet2.Cells(Rows.Count, Col).End(xlUp).Row
 coll = WorksheetFunction.CountIf(Sheet1.Range("I" & i, "AG" & i), "OK")
 For j = 1 To coll
  Sheet2.Range("A" & LR2 + j).Value = Sheet1.Range("A" & i).Value
  Sheet2.Range("B" & LR2 + j).Value = Sheet1.Range("B" & i).Value
  Sheet2.Range("C" & LR2 + j).Value = Sheet1.Range("C" & i).Value
  Sheet2.Range("D" & LR2 + j).Value = Sheet1.Range("D" & i).Value
  Sheet2.Range("E" & LR2 + j).Value = Sheet1.Range("E" & i).Value
  Sheet2.Range("F" & LR2 + j).Value = Sheet1.Range("F" & i).Value
  Sheet2.Range("G" & LR2 + j).Value = Sheet1.Range("G" & i).Value
  Sheet2.Range("H" & LR2 + j).Value = Sheet1.Range("H" & i).Value
  Sheet2.Range("I" & LR2 + j).Value = Sheet1.Range("H1").Offset(0, j).Value
  s = s + 1
 Next j


Next i
End With
Application.ScreenUpdating = True




End Sub

The code above creates all I need EXCEPT "I" column that is messed up. I know that I need a variable that counts the column where the OK is and return the header, but I don't know how to make it work.

Please help a bit.

 

[Fluff]

Hi & welcome to the board
Try this

Sub BlankLine()

Application.ScreenUpdating = False

    Dim Cl As Range
    Dim Cnt As Long

    With Sheet4
        For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            Cnt = WorksheetFunction.Countif(Cl.Offset(, 8).Resize(, 25), "OK")
            If Not Cnt = 0 Then
                sheet9.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(1 * Cnt, 8).Value = Cl.Resize(, 8).Value
                sheet9.Range("I" & Rows.Count).End(xlUp).Offset(1).Resize(Cnt).Value = _
                    Cl.Offset(, 8).Resize(, 25).SpecialCells(xlConstants).Value
            End If
        Next Cl
    End With
    
Application.ScreenUpdating = True

End Sub

 

[Fluff]

Forgot to mention that you'll need to change the sheet references to match yours

 

[oldbrewer]

name

001

002

003

004

005

006

007

008

009

010

bill

ok

ok

ok

ok

ok

fred

ok

ok

ok

ok

ok

ok

bill

001

bill

003

bill

004

bill

006

bill

009

fred

002

fred

003

fred

005

this macro produced the lower table

fred

006

fred

008

Sub Macro5()

fred

009

'

' Macro5 Macro

' Macro recorded 31/10/2017 by bob

'

'

Dim myname(50), mytest(50)

rrow = 3

For j = 2 To 3

For k = 2 To 11

If Cells(j, k) = "ok" Then GoTo 50 Else GoTo 100

50 Sum = Sum + 1

myname(Sum) = Cells(j, 1)

mytest(Sum) = Cells(1, k)

100 Next k

For z = 1 To Sum

rrow = rrow + 1

Cells(rrow, 1) = myname(z)

Cells(rrow, 2) = mytest(z)

Next z

Sum = 0

Next j

End Sub

<colgroup><col width="64" span="14" style="width:48pt"> </colgroup><tbody>
</tbody>