如何修改VBA宏实现动态VLOOKUP公式批量填充至第15行？

当前VBA宏仅能处理前两行数据，需修改使其支持第2行到第15行以及所有右侧列的计算，具体公式规则如下：

• 第2行（如J2）：=VLOOKUP($I3;Sheet2!$I:$AA;MATCH(Sheet1!J1;Sheet2!$I$1:$AA$1;0);0)-VLOOKUP($I2;Sheet2!$I:$AA;MATCH(Sheet1!J1;Sheet2!$I$1:$AA$1;0);0)，即Sheet2中I3对应值减去I2对应值
• 第3行（如J3）：=(VLOOKUP($I3;Sheet2!$I:$AA;MATCH(Sheet1!J1;Sheet2!$I$1:$AA$1;0);0)-1)/VLOOKUP($I2;Sheet2!$I:$AA;MATCH(Sheet1!J1;Sheet2!$I$1:$AA$1;0);0)，即（Sheet2中I3对应值-1）除以I2对应值
• 第4行到第15行：按相同规律，动态调整VLOOKUP的查找值（对应I列当前行的下一行和当前行），列索引由MATCH动态获取

原宏代码 #

Sub VLookup()

Dim I As Integer
Dim lastRow As Long
Dim vlookup1 As Long
Dim vlookup2 As Long

   
 Set sh1 = ThisWorkbook.Worksheets("Sheet1")
 Set sh2 = ThisWorkbook.Worksheets("Sheet2")
 
       
I = 10
 
 While sh1.Cells(1, I) <> ""
         
        vlookup1 = Application.VLookup(sh1.Range("I3"), sh2.Range("I:AA"), Application.Match(sh1.Cells(1, I), sh2.Range("I1:AA1"), 0), 0)
        
        vlookup2 = Application.VLookup(sh1.Range("I2"), sh2.Range("I:AA"), Application.Match(sh1.Cells(1, I), sh2.Range("I1:AA1"), 0), 0)
        
              
       sh1.Cells(2, I) = vlookup1 - vlookup2
       sh1.Cells(3, I) = Format((vlookup1 - 1) / vlookup2, "0%")
            
I = I + 1

Wend

End Sub

修改后的宏代码 #

Sub VLookup_ProcessAllRows()
    Dim col As Integer
    Dim rowNum As Integer
    Dim matchCol As Integer
    Dim lookupValCurrent As Variant
    Dim lookupValNext As Variant
    Dim valCurrent As Variant
    Dim valNext As Variant
    
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    
    Set sh1 = ThisWorkbook.Worksheets("Sheet1")
    Set sh2 = ThisWorkbook.Worksheets("Sheet2")
    
    ' 从第10列（J列）开始遍历所有有表头的列
    col = 10
    Do While sh1.Cells(1, col) <> ""
        ' 获取当前列对应的Sheet2的列索引，增加错误判断
        matchCol = Application.Match(sh1.Cells(1, col), sh2.Range("I1:AA1"), 0)
        If Not IsError(matchCol) Then
            ' 遍历第2行到第15行
            For rowNum = 2 To 15
                ' 动态获取当前行和下一行的I列值作为查找依据
                lookupValCurrent = sh1.Cells(rowNum, "I").Value
                lookupValNext = sh1.Cells(rowNum + 1, "I").Value
                
                ' 在Sheet2中查找对应列的数值
                valCurrent = Application.VLookup(lookupValCurrent, sh2.Range("I:AA"), matchCol, 0)
                valNext = Application.VLookup(lookupValNext, sh2.Range("I:AA"), matchCol, 0)
                
                ' 根据行号应用对应公式逻辑
                If rowNum = 2 Then
                    sh1.Cells(rowNum, col) = valNext - valCurrent
                Else
                    ' 避免除数为0报错
                    If valCurrent <> 0 Then
                        sh1.Cells(rowNum, col) = Format((valNext - 1) / valCurrent, "0%")
                    Else
                        sh1.Cells(rowNum, col) = "N/A"
                    End If
                End If
            Next rowNum
        End If
        col = col + 1
    Loop
End Sub

修改说明 #

1. 新增行循环：添加For rowNum = 2 To 15循环，覆盖第2到15行的计算需求
2. 动态查找值：根据当前行号，自动取I列当前行和下一行的值作为VLOOKUP的查找参数
3. 优化效率与容错：提前计算MATCH结果并缓存，增加错误判断确保列匹配有效；百分比计算时增加除数非零判断，避免运行时错误
4. 语义化变量：修改变量名使其更易读，提升代码维护性

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