VBA-код для поиска столбца для следующей непустой ячейки, переместитесь на 1 ячейку вверх и вставьте в нее что-нибудь

Question

Я новичок в VBA и мне нужен код, чтобы найти следующую непустую ячейку в столбце B (пока не останется больше строк с данными), скопируйте заголовок B5: последняя непустая ячейка в строку выше, где она была найдена непустая ячейка (сейчас это B5: P5, но она будет меняться каждый раз, когда наступает новый месяц. Каждый из этих заголовков используется для сводных таблиц.

По сути, это загрузка из бухгалтерского программного обеспечения, и она неправильно отформатирована с заголовками, поэтому я должен добавить их вручную. Каждый из разделов на листе имеет разные размеры и будет продолжать меняться в размере, когда год прогрессирует, и используются дополнительные учетные коды.

В данный момент у меня нет кода.

Пример строки заголовка в строке 5

MainAccount DEPT    Dep Lookup  Dep Lookup  Dep Lookup  PROD

Давайте просто скажем, что первая точка данных, найденная в столбце B, найдена в B28, мне нужно скопировать и вставить строку заголовка из B5: последний в ряду в строке чуть выше, где были найдены первые данные в B28, что означает что оно будет вставлено начиная с B27.

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

Теперь он снова смотрит в столбец B и находит следующую точку данных в B100. Мне нужно скопировать и вставить заголовок из B5: последний в ряду в B99. Это продолжает делать это, пока нет больше данных. Расположение данных в строках будет меняться от месяца к месяцу.

76200               
76200   1000            
76200   2020            
76200   2100            
76200   2110            
76200   2115    

Я ожидаю, что каждый раз, когда коды находят значение в столбце B, он поднимется на 1 строку и вставит в него заголовок. Это будет происходить до тех пор, пока данных больше не будет (в основном строки будут пустыми).

Answer 1

Я попробовал это и думаю, что у меня есть рабочее решение. Хотя я сделал предположение, что все ваши заголовки находятся в строке без пустых ячеек между ними ... если это не так, вы можете просто отредактировать часть "Selection.End (xlToRight)" оператора Range, прежде чем он скопирует заголовки, так что он включает в себя все заголовки.

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

Answer 2

Допущения:
1. Самая левая ячейка заголовка для вставки - B5.
2. Самая правая ячейка заголовка для вставки неизвестна.
3. последние данные в строке 5 являются частью заголовка для вставки.

Вот подпрограмма:

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