Need Urgent Help with Macro to send data across instead of down.

Please help me solve this problem. I have had assistance before and the macro written works perfectly however I don't know how to adjust for different size data... see attached file called "Excel Problem looking for Help".

Option Explicit
Sub test()

Dim lrow As Long, newlrow As Long, maxcoladd As Long, data, DOBstart As Long, MEMend As Long, result, n As Long, icounter As Long, z As Long, _
i As Long, temp, j As Long, k As Long, m As Long, t As Integer

lrow = Cells(Rows.Count, 1).End(xlUp).Row
If lrow = 1 Then Exit Sub

Application.ScreenUpdating = 0

With Range("a1", Cells(Rows.Count, Cells(1, Columns.Count).End(xlToLeft).Column).End(xlUp))
    .Sort key1:=Range("a1"), Header:=xlYes
    .Subtotal 1, xlCount, 1
    newlrow = Cells(Rows.Count, "b").End(xlUp).Row - 1
    maxcoladd = Application.Max(Range("b1:b" & newlrow))
    ActiveSheet.UsedRange.RemoveSubtotal
    Columns(1).Delete
    data = .Value
End With

DOBstart = 2 + maxcoladd * 6
MEMend = 8 + maxcoladd * 6

ReDim result(0 To lrow, 1 To MEMend)

result(0, 1) = "FacilityProperName"

For n = 2 To 1 + maxcoladd * 6 Step 6
    icounter = icounter + 1
    result(0, n) = "MEM" & icounter
    result(0, n + 1) = "DOB" & icounter
    result(0, n + 2) = "Charla" & icounter
    result(0, n + 3) = "Renee" & icounter
    result(0, n + 4) = "MCN" & icounter
    result(0, n + 5) = "NPI" & icounter
Next

z = 8

For n = DOBstart To MEMend
    result(0, n) = data(1, z)
    z = z + 1
Next

For i = 2 To lrow
    If temp = data(i, 1) Then
        For t = 2 To 7
            result(j, k) = data(i, t)
            k = k + 1
        Next
    Else
        temp = data(i, 1)
        j = j + 1
        For k = 1 To 7
            result(j, k) = data(i, k)
        Next
        m = 8
        For n = DOBstart To MEMend
            result(j, n) = data(i, m)
            m = m + 1
        Next
        k = 8
    End If
Next

With Sheets.Add.Range("a1").Resize(j + 1, MEMend)
    .Value = result
    .EntireColumn.AutoFit
    .Borders.LineStyle = xlContinuous
    .Resize(1).Interior.Color = RGB(219, 229, 241)
End With

Application.ScreenUpdating = 1

End Sub

Hello rzcb,

Your file didn't attach. You should try attaching it again.