VBA Code to search column for next non empty cell, move up 1 cell & paste something into it.. do until it done

Question

I'm new to VBA and need code to find the next non-empty cell in column B (until there are no more rows with data), copy header B5:Last non-empty cell into the row above where it found the non-empty cell(right now it's B5:P5, but it will change each time there is a new month. Each of these headers is used for pivot tables.

Basically, this is a download from accounting software and it isn't formatted correctly with headers, so I have to add them manually. Each of the sections in the worksheet is different sizes and will continue to change in size when the year progresses and additional accounting codes are used.

I do not have any code at this time.

Example of Header Row in Row 5

MainAccount DEPT    Dep Lookup  Dep Lookup  Dep Lookup  PROD

Let's just say that the first data point found in column B is found at B28, I need the header row copied and pasted from B5: last in a row to the row just above where it found the first data in B28, meaning that it will be pasted starting in B27.

61000   2110                
61000   2110                1
61000   2110                3
61000   2120                
61000   2120                1
61000   2120                3
61000   2120                4

Now it looks again in column B and finds the next data point in B100. I need the header copied and pasted from B5:last in row to B99. It keeps doing this until there is no more data. The placement of the data in rows will change from month to month.

76200               
76200   1000            
76200   2020            
76200   2100            
76200   2110            
76200   2115    

I expect that for each time the codes finds a value in column B, that it will go up 1 row and paste the header into it. It will do this until there is no more data (basically, the rows will just be blank).

Answer 1

Assumptions:
1. left most cell of the header to insert is B5.
2. right most cell of the header to insert is unknown.
3. last data in row 5 is part of the header to insert.

Here is the subroutine:

Public Sub insertHeader()

    'add an error handler
    On error goto errHandler

    'declare variables to use
    dim oRangeHeader as Excel.Range 'range object of header
    dim lColLastHeader as long 'last column of header
    dim lRowLastColOfB as long 'last row of column B with data
    dim lRowLastColOfB as long 'last row of column B with data
    dim lRowOfBLoop as long 'row loop variable of column B
    dim lRowOfBLoopEmpty as long 'empty row in column B

    'get the last column of the header to insert
    lColLastHeader= Activesheet.Cells(5,Application.Columns.Count).End(xlToLeft).Column

    'set to range object variable the header
    set oRangeHeader = Activesheet.Range(cells(5,2), cells(5,lColLastHeader))

    'check if last row of column B has data
    if len(Activesheet.range("B" & application.rows.count).value) = 0 then
        'length is zero = no data
        'get the last row of column B with data            
        lRowLastColOfB = Activesheet.range("B" & application.rows.count).end(xlUp).Row
    else
        'length is greater than zero
        lRowLastColOfB = application.rows.count
    end if

    'check if value of last row of column B is greater than the row of header
    if lRowLastColOfB > 5 then
        'set to 0 the empty row variable in column
        lRowOfBLoopEmpty = 0
        'create a loop from B6 to last row of B
        for lRowOfBLoop = 6 to lRowLastColOfB 
            'check if cell is empty
            if len(Activesheet.range("B" & lRowOfBloop).value) = 0 then
                'set the row of B loop to variable for empty row in B 
                lRowOfBLoopEmpty = lRowOfBloop
            else
                'check if variable for empty row is 0
                if lRowOfBLoopEmpty > 0 then
                    oRangeHeader.copy 
                    Activesheet.Range("B" & lRowOfBLoopEmpty).select
                    Activesheet.Paste
                    Activesheet.Range("B" & lRowOfBLoop).select
                    Application.CutCopyMode = false  
                    lRowOfBLoopEmpty = 0
                End If
            End If
        Next lRowOfBLoop
    End If

exitHandler:
    Set oRangeHeader = Nothing
    Exit Sub

errHandler:
    If err.number <> 0 then
        msgbox err.description & " " & err.number, vbOKOnly+vbInformation, "addHeader"
        err.clear
    end if
    Set oRangeHeader = Nothing
End Sub

Answer 2

I've had a go at this and think I have a working solution. Though I have made assumptions that all of your headers are in a row without empty cells between them... if this is not the case, you can simply edit the "Selection.End(xlToRight)" part of the Range statement before it copies the headers, so that it includes all of the headers.

Sub LoopForColumnHeaders()
'
' This macro copies headers from a defined range ("B5":End of row) and pastes it above each encountered row of data as a header

    ' Copy the headers
    Range("B5").Select
    Range(Selection, Selection.End(xlToRight)).Select       ' Does the same as Ctrl + Shift + Right
    Selection.Copy                                          ' Copy the headers

    ' Pasting the first headers
    Selection.End(xlDown).Select                ' Does the same as Ctrl + down
    Selection.Offset(-1, 0).Activate            ' Move up one row
    ActiveSheet.Paste                           ' Paste the headers

    ' Pasting subsequent headers

    Do While Idx < 1048575                      ' Change this value if you want to, it determines when the loop will stop, but I didn't want to assume the length of your data so I set it to max rows - 1
        Selection.End(xlDown).Select            ' Does the same as Ctrl + down
        Selection.End(xlDown).Select            ' Do it again to get to next code chunk
        If Not IsEmpty(ActiveCell) Then         ' Check this cell is not empty (bottom of page if data does not reach this far)
            Selection.Offset(-1, 0).Activate    ' Move up one row
            If IsEmpty(ActiveCell) Then         ' Check if this cell is empty
                ActiveSheet.Paste               ' Paste the headers
            End If
        End If
        Idx = ActiveCell.Row                    ' Set the value of Idx equal to current row
    Loop


End Sub