Convert Horizontal Data to a Vertical Format

[skifiend]

I have a table of data such that specific columns of the information needs to be converted from a horizontal layout and inserted below the initial row. To make things more complex any column with a value of zero needs to be ignored and each row may have a different column with a zero.

This query is super close, but for some reason when run it on this data set it is not picking up all the horizontal data. For some reason it is stopping at column "S" rather than going to column "CZ". Also in rows where there are zeros in column "B" it does not pick up the account number and just adds the Revenue Code and Charges to the name above it (see where account 123123141 was skipped, but the object numbers were added to 123123140).

Sub H2V()
' Vertically integrate horizontal revenue code data
' Keyboard Shortcut: Ctrl+Shift+Q
    Dim headers As Variant, names As Variant, data As Variant
    Dim iRow As Long

    With Worksheets("Template")
        With Intersect(.UsedRange, .Range("A:CZ"))
            headers = Application.Transpose(Application.Transpose(.Offset(, 1).Resize(1, .Columns.Count - 1).Value))
            names = Application.Transpose(.Offset(1).Resize(.Rows.Count - 1, 1).Value)
            data = .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1).Value
            .ClearContents
            .Resize(1, 3).Value = Array("Patient Number", "Rev Code", "Charges")
        End With

        For iRow = 1 To UBound (data)
            With .Cells(.Rows.Count, "B").End(xlUp)
                .Offset(1, -1).Value = names(iRow)
                .Offset(1, 0).Resize(UBound(headers)).Value = Application.Transpose(headers)
                .Offset(1, 1).Resize(UBound(data)).Value = Application.Transpose(Application.Index(data, iRow, 0))
            End With
        Next

        With .Range("B3", Cells(.Rows.Count, "B").End(xlUp)).SpecialCells(xlCellTypeConstants)
            .Offset(, 1).Replace What:="0", Replacement:="", LookAt:=xlWhole
            .Offset(, 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        End With
    End With
End Sub

Raw Data:
Data Set (horizontal).png

Post Fix (incomplete):
Post Fix Data Set (Vertical).png