How to combine multiple rows making one column into several

Please take a little time to study the code below. I took some pains to show you a few things that are very simple but you did them in a very complicated way. There are also a few things you didn't try but will find useful to know. On the whole, I think the code does what you intend. Before you run it on your workbook note that your worksheet Raw data as entered has blank spaces at the end of its name. Therefore the code can't recognize it. Remove the blanks from its name.

Option Explicit
Enum Nws                ' worksheet "Input" (Arr) navigation
    ' 068
    NwsFirstDataRow = 2
    NwsAcct = 1         ' name the columns
    NwsName
    NwsRep
    NwsCode
    NwsLoc
    NwsTheme
    NwsItem
End Enum
Sub InputToOutput()
    '068
    
    Dim WsIn            As Worksheet            ' data input
    Dim WsOut           As Worksheet            ' result
    Dim Rng             As Range                ' working range
    Dim Arr             As Variant              ' contents (Value) of a range
    Dim R               As Long                 ' loop counter (row in Input/Arr)
    Dim C               As Long                 ' loop counter (column in Input/Arr)
    Dim Fnd             As Range                ' search result
    Dim Rt              As Long                 ' target row (in Output)
    Dim Ct              As Long                 ' target column (in Output)
    
    Application.ScreenUpdating = False          ' saves time
    Set WsIn = Worksheets("Raw data as entered")
    On Error Resume Next
    Set WsOut = Worksheets("Output")            ' rename to suit
    If Err Then                                 ' error if no such Ws
        ' append a copy of Input at the end
        Worksheets("Input").Copy After:=Worksheets(Worksheets.Count)
        Set WsOut = ActiveSheet
        With WsOut
            .Name = "Output"
            Set Rng = .Range(.Cells(1, 1), .Cells(1, NwsLoc))
            Arr = Rng.Value                     ' copy captions to Arr
            ' retain only some captions and column formatting
            .Cells.ClearContents
            Rng.Value = Arr                     ' return Arr to first row
        End With
    End If
    On Error GoTo 0
    With WsIn
        ' read all data into array Arr
        Arr = .Range(.Cells(NwsFirstDataRow, "A"), .Cells(.Rows.Count, "A").End(xlUp)) _
                     .Resize(, .Cells(1, .Columns.Count).End(xlToLeft).Column).Value
    End With
    
    With WsOut
        For R = 1 To UBound(Arr)
            Rt = Application.Max(.Cells(.Rows.Count, NwsAcct).End(xlUp).Row, _
                                  NwsFirstDataRow)
            ' look at all existing account numbers
            Set Rng = .Range(.Cells(NwsFirstDataRow, NwsAcct), _
                             .Cells(Rt, NwsAcct))
            ' find the account number
            Set Fnd = Rng.Find(What:=Trim(Arr(R, NwsAcct)), _
                               LookIn:=xlValues, LookAt:=xlWhole, _
                               SearchOrder:=xlByRows, SearchDirection:=xlNext)
            If Fnd Is Nothing Then
                ' set up a new row
                Rt = .Cells(.Rows.Count, NwsAcct).End(xlUp).Row + 1
                For C = NwsAcct To NwsLoc
                    .Cells(Rt, C).Value = Arr(R, C)
                Next C
            Else
                Rt = Fnd.Row                    ' target row
            End If
            
            For C = NwsTheme To NwsItem
                If Len(Trim(Arr(R, C))) Then    ' skip if blank
                    Ct = .Cells(1, .Columns.Count).End(xlToLeft).Column
                    Set Rng = .Range(.Cells(1, NwsTheme), .Cells(1, Ct))
                    ' find the theme or item
                    Set Fnd = Rng.Find(What:=Arr(R, C), _
                                       LookIn:=xlValues, LookAt:=xlWhole, _
                                       SearchOrder:=xlByColumns, _
                                       SearchDirection:=xlNext)
                    If Fnd Is Nothing Then
                        ' set up a new theme or item
                        .Columns(Ct).Copy .Columns(Ct + 1)
                        Ct = Ct + 1
                        .Columns(Ct).ClearContents
                        .Cells(1, Ct).Value = Arr(R, C)
                        .Columns(Ct).AutoFit
                    Else
                        Ct = Fnd.Column
                    End If
                    
                    .Cells(Rt, Ct).Value = "Y"
                End If
            Next C
        Next R
    End With
    
    Application.ScreenUpdating = True           ' update the screen now
End Sub

The code looks for a worksheet called Output. If it doesn't exist it's created, taking captions and column formats from the sheet "Raw data as entered". This means that you can run the code on the same Output sheet several times. There is no advantage in doing so because the code will run through all 15K lines anyway. It only adds to the existing but doesn't delete. That could be a source of errors.

The code first looks for an account number in Output and creates it if it isn't found. Then it looks for Themes and Items, in turn, also creating these columns if they don't exist. Finally it writes "Y"s in the appropriate columns.

The best way to use the code should be to prepare the Output sheet with the column captions F:?? sorted  the way you want. That will force the code to use existing columns. If it still adds columns during its run the reason is misspelling either in the setup or in the data capture.

BTW the code reads the account numbers as numbers and finds them as numbers. In your raw data the are followed by a lot of blanks. Blanks are a sure source of problems. Please don't believe that they don't exist because you don't see them. The only thing you don't see is why your code doesn't work lol:  Whatever effect you wish to achieve by their use, achieve it with cell formatting instead.