Create flat file from data download

I am having some difficulty taking a raw data download and making it into a flat file. Would it be possible to help me with the code to generate the flat file from exisitng data?

I attached a sample spreadsheet with input as I get it (merged and missing two columns of data) and also an output version showing what I hope to eventually achieve.

I added a column for "Site" and one for "Therapy". Getting those new columns populated in VBA is the toughest challenge for me (but by no means the only one). Another part I struggle with a bit is that some cells are merged.

Any help is greatly appreciated.

-Michael

hi, Michael, it can be done this way, run code "test"

PS. I did not understand why Perkins, Ruby became Person 13. On the result sheet he will remain Perkins, Ruby.

watersev,

Thank you very much for providing this working solution. I tested it on live data and the program produced good output. Amazingly fast and clean compared to anything I could have come up with!

The only difference I see in matching the data is that the flat file is off a small amount per site due to rounding and I am not sure quite where to adjust the code. After I figure that out, it is letter perfect.

Thanks again!

-Michael

I have one last question on this problem. Looking at the msmithdynamicsgp.xlsm sample posted above:

In the 'input' sheet, I found that column Q (Supplies) has a precision of four decimal places.

The corresponding 'output' sheet in column J (Supplies) is rounded off to two decimal places.

How can I revise this so that the level of precision is not lost? i.e. so that the output sheet in column j keeps all four decimal places?

I tried changing the data type Long below to Double, but that did not change the output at all. I also tried messing with the numberformat, which I knew had nothing to do with precision.

Any ideas?

Option Explicit
Sub test()
Dim x, y, col, vl, i As Long, j As Long, m As Integer, site As String, therapy As String
Application.ScreenUpdating = False: With Sheets("input"): x = .Range(.[a9], .Cells(Rows.Count, "a").End(xlUp).Offset(, 22)): End With
ReDim y(1 To UBound(x), 1 To 11): col = Array(1, 2, 3, 5, 10, 12, 13, 17, 20): m = 2
For i = 1 To UBound(x)
    If x(i, 1) = "Therapy:" Then
        If x(i - 2, 1) = "" Then site = x(i - 1, 1)
            therapy = x(i, 2): i = i + 1
        Do
           j = j + 1: y(j, 1) = site: y(j, 2) = therapy
            For Each vl In col
                m = m + 1: y(j, m) = x(i, vl)
            Next: m = 2: i = i + 1
        Loop Until InStr(1, x(i, 1), "Total:") > 0
End If
Next: With Sheets("output").[a2].Resize(j, 11): .Value = y: .Offset(, 6).Resize(, 5).NumberFormat = "0.00": End With
Application.ScreenUpdating = True: End Sub