Question

我是VBA的新手，需要代码来查找B列中的下一个非空单元格（直到不再有数据行），将标头B5：Last非空单元格复制到找到它的行中非空单元格（现在是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：last in row复制并粘贴到B99。它会一直这样做，直到没有更多数据为止。数据在行中的位置会随着月份的变化而变化。

76200               
76200   1000            
76200   2020            
76200   2100            
76200   2110            
76200   2115

我希望每次代码在B列中找到一个值时，它都会上升1行并将标头粘贴到其中。它将执行此操作，直到没有更多数据为止（基本上，行将为空白）。

Answer 1

我已经尝试过了，认为我有一个可行的解决方案。尽管我已经假设所有标头都位于一行中，并且它们之间没有空单元格...如果不是这种情况，您可以在复制之前简单地编辑Range语句的“ Selection.End（xlToRight）”部分标头，以便包含所有标头。

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

VBA代码以搜索列中的下一个非空单元格，向上移动1个单元格并将其粘贴到其中。.做直到完成

2 个答案: