VBA动态范围：如何将公式复制到新的最后一行？

算力阿峰

2026-7-22

动态列公式自动填充的VBA解决方案

问题描述

通过列标题名称动态识别多列，从KOB1工作表向Report工作表粘贴数据后，需要将带公式的列（如Unique ID、Project Lead、Project Name等）的公式复制到新添加的行。要求列位置动态可变，只要表头名称正确，不管用户把这些列放在Report的哪个位置都能正常工作。目前其他功能已实现，仅公式自动填充部分未完成。

现有代码

Sub Auto_Add()
Dim wsK, wsR As Worksheet
Set wsR = ActiveWorkbook.Worksheets("Report")
Set wsK = ActiveWorkbook.Worksheets("KOB1")
Dim LR, LC, FR, LR1 As Long
Dim r1, r2, ra, rb, rc, rd, re, Rng, HeaderRow, rngHeaders, rngHdrFound1, rngHdrFound2, rngHdrFound3, rngHdrFound4, rngHdrFound5, rngHdrFound6 As Range

FR = wsR.Range("A1").End(xlDown).Row
LR = wsR.Range("A3").SpecialCells(xlLastCell).Row
LC = wsR.Range("A1").SpecialCells(xlLastCell).Column

wsR.Select
Set Rng = Range(Cells(FR, 1), Cells(LR, LC))
Set HeaderRow = Range(Cells(FR, 1), Cells(FR, LC))

Const HEADER_NAME_1 As String = "Order Number"
Const HEADER_NAME_2 As String = "CE Groups"
Const HEADER_NAME_3 As String = "Vendor"
Const HEADER_NAME_4 As String = "PO"
Const HEADER_NAME_5 As String = "Current Month Actuals"
Const HEADER_NAME_6 As String = "Unique ID"

Set rngHeaders = Intersect(wsR.UsedRange, wsR.Rows(FR))
Set rngHdrFound1 = rngHeaders.Find(HEADER_NAME_1)
Set rngHdrFound2 = rngHeaders.Find(HEADER_NAME_2)
Set rngHdrFound3 = rngHeaders.Find(HEADER_NAME_3)
Set rngHdrFound4 = rngHeaders.Find(HEADER_NAME_4)
Set rngHdrFound5 = rngHeaders.Find(HEADER_NAME_5)
Set rngHdrFound6 = rngHeaders.Find(HEADER_NAME_6)

Set OrderNumber = rngHdrFound1.End(xlDown).Offset(1) 'I have these as Offset so it will go to the next (blank) cell underneath
Set CEGroups = rngHdrFound2.End(xlDown).Offset(1)
Set Vendor = rngHdrFound3.End(xlDown).Offset(1)
Set PO = rngHdrFound4.End(xlDown).Offset(1)
Set CurrentMonthActuals = rngHdrFound5.End(xlDown).Offset(1)
Set UID = rngHdrFound6.End(xlDown) 'I do not have this as an offset so you are able to select the formula

'this code starts identifying and organizing fields for what I need to get from "KOB1" tab....

If wsK.FilterMode Then
wsK.ShowAllData
End If

If wsR.FilterMode Then
wsR.ShowAllData
End If

wsR.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2

LR1 = wsK.Range("B" & Rows.Count).End(xlUp).Row

wsK.Range("$A$7:$M" & LR1).AutoFilter Field:=11, Criteria1:="ADD"

wsK.Select

Set r1 = wsK.AutoFilter.Range
Set r2 = Intersect(r1.Offset(1, 0), r1)
Set ra = Intersect(r2, Columns(3))
Set rb = Intersect(r2, Columns(5))
Set rc = Intersect(r2, Columns(9))
Set rd = Intersect(r2, Columns(8))
Set re = Intersect(r2, Columns(10))

ra.Copy 'Order Number
OrderNumber.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

'...rest of code to grab what I need to from the "KOB1" tab and paste into the "Report" tab, works just fine...

Dim LR2 As Long   'This is one way to identify the new Last Row after pasting from the code(s) above
With wsR
LR2 = .Cells.Find("*", Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False).Row
End With

'THIS IS WHERE I NEED HELP (I THINK)!!!
UID.Copy
wsR.Range("A4:A" & LR2).Select 'I don't want to have to specify the Column range (A, B, C, etc.. OR the Row # A4, B4, etc...) It needs to be dynamic
ActiveSheet.Paste
End Sub

尝试过的方法（未成功）

Dim LR3 As Long
LR3 = Range(Selection, Selection.End(xlDown)).Select
UID.Select
Range("A" & LR3).AutoFill Destination:=Range("A" & LR3 & ":A")
Range(Selection, Selection.End(xlDown)).Select

补充的其他公式列定义

'Some of the other variables:

Const HEADER_NAME_7 As String = "Project Lead"
Const HEADER_NAME_8 As String = "Project Name"
Const HEADER_NAME_9 As String = "RPA"
Const HEADER_NAME_10 As String = "Order Name"
Const HEADER_NAME_11 As String = "Accrual Amount Expected"
Const HAEDER_NAME_12 As String = "Scrub Accrual?" '注意：原代码此处拼写错误，应为HEADER_NAME_12
Const HEADER_NAME_13 As String = "Current Month Var"

Set rngHdrFound7 = rngHeaders.Find(HEADER_NAME_7)
Set rngHdrFound8 = rngHeaders.Find(HEADER_NAME_8)
Set rngHdrFound9 = rngHeaders.Find(HEADER_NAME_9)
Set rngHdrFound10 = rngHeaders.Find(HEADER_NAME_10)
Set rngHdrFound11 = rngHeaders.Find(HEADER_NAME_11)
Set rngHdrFound12 = rngHeaders.Find(HEADER_NAME_12)
Set rngHdrFound13 = rngHeaders.Find(HEADER_NAME_13)

Set ProjectLead = rngHdrFound7.End(xlDown)
Set ProjectName = rngHdrFound8.End(xlDown)
Set RPA = rngHdrFound9.End(xlDown)
Set OrderName = rngHdrFound10.End(xlDown)
Set AccrualAmountExpected = rngHdrFound11.End(xlDown)
Set ScrubAccrual = rngHdrFound12.End(xlDown)
Set CurrentMonthVar = rngHdrFound13.End(xlDown)

解决方案代码

以下是修正并优化后的完整代码，解决了动态列公式填充的问题，同时修复了原代码中的变量声明、拼写错误等问题：

Sub Auto_Add()
    ' 修正变量声明：每个变量单独指定类型
    Dim wsK As Worksheet, wsR As Worksheet
    Set wsR = ActiveWorkbook.Worksheets("Report")
    Set wsK = ActiveWorkbook.Worksheets("KOB1")
    
    Dim LR As Long, LC As Long, FR As Long, LR1 As Long, LR2 As Long
    Dim r1 As Range, r2 As Range, ra As Range, rb As Range, rc As Range, rd As Range, re As Range
    Dim Rng As Range, HeaderRow As Range, rngHeaders As Range
    Dim rngHdrFound1 As Range, rngHdrFound2 As Range, rngHdrFound3 As Range
    Dim rngHdrFound4 As Range, rngHdrFound5 As Range, rngHdrFound6 As Range
    
    FR = wsR.Range("A1").End(xlDown).Row
    LR = wsR.Range("A3").SpecialCells(xlLastCell).Row
    LC = wsR.Range("A1").SpecialCells(xlLastCell).Column
    
    ' 避免Select，直接操作对象
    Set Rng = wsR.Range(wsR.Cells(FR, 1), wsR.Cells(LR, LC))
    Set HeaderRow = wsR.Range(wsR.Cells(FR, 1), wsR.Cells(FR, LC))
    
    Const HEADER_NAME_1 As String = "Order Number"
    Const HEADER_NAME_2 As String = "CE Groups"
    Const HEADER_NAME_3 As String = "Vendor"
    Const HEADER_NAME_4 As String = "PO"
    Const HEADER_NAME_5 As String = "Current Month Actuals"
    Const HEADER_NAME_6 As String = "Unique ID"
    
    Set rngHeaders = Intersect(wsR.UsedRange, wsR.Rows(FR))
    Set rngHdrFound1 = rngHeaders.Find(HEADER_NAME_1, LookIn:=xlValues, LookAt:=xlWhole)
    Set rngHdrFound2 = rngHeaders.Find(HEADER_NAME_2, LookIn:=xlValues, LookAt:=xlWhole)
    Set rngHdrFound3 = rngHeaders.Find(HEADER_NAME_3, LookIn:=xlValues, LookAt:=xlWhole)
    Set rngHdrFound4 = rngHeaders.Find(HEADER_NAME_4, LookIn:=xlValues, LookAt:=xlWhole)
    Set rngHdrFound5 = rngHeaders.Find(HEADER_NAME_5, LookIn:=xlValues, LookAt:=xlWhole)
    Set rngHdrFound6 = rngHeaders.Find(HEADER_NAME_6, LookIn:=xlValues, LookAt:=xlWhole)
    
    Set OrderNumber = rngHdrFound1.End(xlDown).Offset(1)
    Set CEGroups = rngHdrFound2.End(xlDown).Offset(1)
    Set Vendor = rngHdrFound3.End(xlDown).Offset(1)
    Set PO = rngHdrFound4.End(xlDown).Offset(1)
    Set CurrentMonthActuals = rngHdrFound5.End(xlDown).Offset(1)
    
    ' 清除筛选
    If wsK.FilterMode Then wsK.ShowAllData
    If wsR.FilterMode Then wsR.ShowAllData
    
    wsR.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2
    
    LR1 = wsK.Range("B" & wsK.Rows.Count).End(xlUp).Row
    wsK.Range("$A$7:$M" & LR1).AutoFilter Field:=11, Criteria1:="ADD"
    
    Set r1 = wsK.AutoFilter.Range
    Set r2 = Intersect(r1.Offset(1, 0), r1)
    Set ra = Intersect(r2, wsK.Columns(3))
    Set rb = Intersect(r2, wsK.Columns(5))
    Set rc = Intersect(r2, wsK.Columns(9))
    Set rd = Intersect(r2, wsK.Columns(8))
    Set re = Intersect(r2, wsK.Columns(10))
    
    ' 复制粘贴值，避免Select
    ra.Copy
    OrderNumber.PasteSpecial Paste:=xlPasteValues
    
    '...保留原有的其他数据粘贴代码...
    
    ' 获取粘贴后的新最后一行
    With wsR
        LR2 = .Cells.Find("*", .Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False).Row
    End With

    ' ------------------------------
    ' 核心：动态处理所有公式列的填充
    ' ------------------------------
    Dim formulaHeaders As Variant
    ' 把所有需要填充公式的表头放到数组中，方便维护
    formulaHeaders = Array("Unique ID", "Project Lead", "Project Name", "RPA", _
                          "Order Name", "Accrual Amount Expected", "Scrub Accrual?", _
                          "Current Month Var")
    
    Dim header As Variant
    Dim foundCol As Range
    Dim lastFormulaRow As Long
    
    For Each header In formulaHeaders
        ' 精准查找表头（完全匹配）
        Set foundCol = rngHeaders.Find(header, LookIn:=xlValues, LookAt:=xlWhole)
        If Not foundCol Is Nothing Then
            ' 找到该列最后一个有公式/内容的行
            lastFormulaRow = wsR.Cells(wsR.Rows.Count, foundCol.Column).End(xlUp).Row
            ' 如果最后一个公式行在新最后一行之上，说明需要填充
            If lastFormulaRow < LR2 Then
                ' 从最后一个公式行向下填充到LR2，自动复制公式
                wsR.Range(wsR.Cells(lastFormulaRow, foundCol.Column), _
                          wsR.Cells(LR2, foundCol.Column)).FillDown
            End If
        End If
    Next header
    
    ' 清除剪贴板
    Application.CutCopyMode = False
End Sub

关键改进点

修正变量声明：VBA中需为每个变量单独指定类型，避免默认Variant类型导致的潜在问题
移除Select/Activate：直接操作工作表和单元格对象，提升代码稳定性和执行效率
动态表头数组：将所有公式列的表头存入数组，通过循环批量处理，后续新增公式列只需修改数组即可
精准表头查找：使用LookAt:=xlWhole确保完全匹配表头名称，避免部分匹配导致错误
自动填充公式：使用FillDown方法自动复制公式到新行，比复制粘贴更高效且能保持公式的相对引用

内容的提问来源于stack exchange，提问作者Mike V

VBA动态范围：如何将公式复制到新的最后一行？

问题描述 #

现有代码 #

尝试过的方法（未成功） #

补充的其他公式列定义 #

解决方案代码 #