如何通过VBA基于Excel另一工作表的零件号列表匹配并修改对应单元格值？

没问题，这是针对你需求的VBA代码，能高效完成Sheet1零件号与Sheet2的匹配，并为匹配到的行设置指定公式：

Sub UpdateQuantityFormulas()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim partList As Range, partCell As Range
    Dim matchRow As Variant
    Dim lastRowWs1 As Long, lastRowWs2 As Long
    
    ' 设置工作表对象
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    
    ' 获取Sheet1中零件号的最后一行
    lastRowWs1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    Set partList = ws1.Range("A2:A" & lastRowWs1) ' 假设表头在第一行，数据从第二行开始
    
    ' 遍历Sheet1的每个零件号
    For Each partCell In partList
        ' 在Sheet2的A列查找当前零件号
        matchRow = Application.Match(partCell.Value, ws2.Columns("A"), 0)
        
        ' 如果找到匹配项
        If Not IsError(matchRow) Then
            ' 设置Quantity 1的公式（C列）
            ws2.Cells(matchRow, "C").Formula = "=" & ws2.Cells(matchRow, "C").Address & "/1000/500"
            ' 设置Quantity 2的公式（D列）
            ws2.Cells(matchRow, "D").Formula = "=" & ws2.Cells(matchRow, "D").Address & "/1000/500"
            
            ' 如果需要直接计算出值而不是保留公式，可以替换成下面两行：
            ' ws2.Cells(matchRow, "C").Value = ws2.Cells(matchRow, "C").Value / 1000 / 500
            ' ws2.Cells(matchRow, "D").Value = ws2.Cells(matchRow, "D").Value / 1000 / 500
        End If
    Next partCell
    
    MsgBox "数量更新完成！", vbInformation
End Sub

代码关键说明： #

• 工作表对象设置：明确指定Sheet1和Sheet2，避免激活/选择工作表（VBA最佳实践）
• 匹配逻辑：用Application.Match快速查找零件号，比循环遍历Sheet2更高效
• 公式设置：使用Address方法引用原单元格，确保公式动态对应到当前行的原始值
• 可选值替换：如果不需要保留公式，直接计算结果的话，可以注释掉公式行，启用下方的直接赋值代码

验证你的示例： #

对于Sheet2中的X23行，代码会为C2和D2设置公式：

• =C2/1000/500 计算后得到 97845/1000/500 = 0.19569（约0.196）
• =D2/1000/500 计算后得到 399987/1000/500 = 0.799974（约0.800）
  完全符合你需要的结果。

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