Conversion unformatted to formatted Excel

Sub Reformat()
    
    Dim LastR As Long, r As Long
    Dim ArrayIn As Variant
    Dim ArrayOut() As Variant
    Dim DestWs As Worksheet
    Dim Entries As Long
    Dim RecordNum As Long
    Dim CityStZIP As String
    
    With ThisWorkbook.Worksheets("RawData")
        ' Determine last row with data
        LastR = .Cells(.Rows.Count, "a").End(xlUp).Row

        ' Dump the original values into an array--faster processing
        ArrayIn = .Range("a1:b" & LastR).Value
    End With
    
    ' loop through each "row" in the array
    For r = 1 To LastR

        ' If Entries = 0 then we are processing the very first item in array
        If Entries = 0 Then
            ' re-dimension array.  Normally I would do the 1-15 as the 2nd
            ' dimension, but since this will keep getting re-sized, only the
            ' last dimension can be dynamic
            ReDim ArrayOut(1 To 15, 1 To 1) As Variant
            Entries = 1
            RecordNum = 1
        End If

        ' The idea here is that each company will have a number
        ' of lines, which I track here with RecordNum.  The line number
        ' you are on for that company determines what data element is
        ' on that line
        Select Case RecordNum
            Case 1
                ArrayOut(10, UBound(ArrayOut, 2)) = ArrayIn(r, 1)
                RecordNum = RecordNum + 1
            Case 2 To 6
                ArrayOut(RecordNum - 1, UBound(ArrayOut, 2)) = ArrayIn(r, 1)
                RecordNum = RecordNum + 1
            Case 7
                ' break out city, st, zip to different fields
                CityStZIP = Trim(Replace(ArrayIn(r, 1), Chr(160), ""))
                ArrayOut(7, UBound(ArrayOut, 2)) = Left(CityStZIP, Len(CityStZIP) - 9)
                ArrayOut(8, UBound(ArrayOut, 2)) = Mid(CityStZIP, Len(CityStZIP) - 7, 2)
                ArrayOut(9, UBound(ArrayOut, 2)) = Right(CityStZIP, 5)
                RecordNum = RecordNum + 1
            ' RecordNum = 8 can be either a web site, of the "company info" label
            Case 8
                If LCase(ArrayIn(r, 1)) <> "company information" Then
                    ArrayOut(6, UBound(ArrayOut, 2)) = ArrayIn(r, 1)
                End If
                RecordNum = RecordNum + 1
            ' For any other RecordNum value, we need to find the stuff in Col B
            ' we know how to find it by looking for "primary sic"
            Case Else
                If LCase(ArrayIn(r, 1)) = "primary sic" Then
                    ArrayOut(11, UBound(ArrayOut, 2)) = ArrayIn(r, 2)
                    ArrayOut(12, UBound(ArrayOut, 2)) = ArrayIn(r + 1, 2)
                    ArrayOut(13, UBound(ArrayOut, 2)) = ArrayIn(r + 2, 2)
                    ArrayOut(14, UBound(ArrayOut, 2)) = ArrayIn(r + 3, 2)
                    ArrayOut(15, UBound(ArrayOut, 2)) = ArrayIn(r + 4, 2)
                    ' if we are not at the end of input, we have at least one more
                    ' company to process, so we have to re-size the array
                    If (r + 5) <= LastR Then
                        Entries = Entries + 1
                        ReDim Preserve ArrayOut(1 To 15, 1 To Entries) As Variant
                        RecordNum = 1
                    End If
                    ' usually incrementing the index variable for a For/Next loop
                    ' is a bad idea, but here I did it to force the program to skip
                    ' the next few lines, because we already processed them above
                    r = r + 4
                Else
                    RecordNum = RecordNum + 1
                End If
        End Select
    Next
    
    Set DestWs = ThisWorkbook.Worksheets.Add
    
    With DestWs
        .Range("a1").Resize(1, 15).Value = Array("ContactName", "Position", "Telephone", "Email", "Address", _
            "Website", "City", "State", "ZIP", "CompanyName", "PrimarySIC", "PrimarySICDescr", _
            "EmployeeSize", "Sales", "CreditDescr")

        ' remember that the array was really "rotated": column values were
        ' in 1st dimension.  To get this into the desired output format, we
        ' have to transpose the data
        .Range("a2").Resize(Entries, 15).Value = Application.Transpose(ArrayOut)
        .Columns.AutoFit
    End With
    
    MsgBox "Done"
    
End Sub

Select allOpen in new window