求助：调整VBA代码实现复制公式时动态更新相对单元格引用

我需要复制Excel单元格区域的公式到新位置，但不想改动原始单元格。自己写的VBA代码能复制公式，但无法自动调整相对引用——比如把B31:H32复制到J31:P32时，H32的=SUM($B31:H31)复制到P32后还是原公式，期望变成=SUM($J31:P31)。原代码尝试手动调整引用但无效，求修改。

原代码（问题版本） #

Sub DuplicateFormulas()
Dim sourceRng As Range
Dim targetCell As Range
Dim cell As Range
Dim subCell As Variant

' Ensure a range is selected
If TypeName(Selection) <> "Range" Then
MsgBox "Please select a range to duplicate first.", vbExclamation
Exit Sub
End If

Set sourceRng = Selection

' Prompt the user to select the destination cell
On Error Resume Next
Set targetCell = Application.InputBox("Select the destination cell:", "Duplicate Formulas", Type:=8)
On Error GoTo 0

If Not targetCell Is Nothing Then

' Iterate through each area in the source range (handles non-contiguous ranges)
For Each cell In sourceRng.Areas
' Iterate through each cell in the area
For Each subCell In cell
' Check if the cell is not empty
If Not IsEmpty(subCell.Value) Then
' Copy the formula to the corresponding cell relative to the target cell
targetCell.Offset(subCell.Row - sourceRng.Row, subCell.Column - sourceRng.Column).formula = subCell.formula

' Adjust relative references within the copied formula
AdjustRelativeReferences targetCell.Offset(subCell.Row - sourceRng.Row, subCell.Column - sourceRng.Column), sourceRng, targetCell

' Copy formatting (optional)
If subCell.HasFormula Then
targetCell.Offset(subCell.Row - sourceRng.Row, subCell.Column - sourceRng.Column).Copy
End If
End If
Next subCell
Next cell

' Paste formatting (optional)
If sourceRng.HasFormula Then
targetCell.PasteSpecial Paste:=xlPasteFormats
End If

End If

End Sub

Sub AdjustRelativeReferences(targetCell As Range, sourceRng As Range, targetRng As Range)

Dim reference As Range
Dim adjustedFormula As String

' Iterate through each direct precedent (referenced cell) of the target cell
For Each reference In targetCell.DirectPrecedents
' Ensure reference is within the copied range
If Not Intersect(reference, sourceRng) Is Nothing Then
' Adjust the reference based on the difference between the source and target ranges
Set reference = targetRng.Worksheet.Cells(reference.Row + targetCell.Row - sourceRng.Row, reference.Column + targetCell.Column - sourceRng.Column)
' Adjust the formula dynamically to be relative
adjustedFormula = Replace(targetCell.formula, reference.Address, reference.Address(ReferenceStyle:=xlR1C1))
adjustedFormula = Replace(adjustedFormula, sourceRng.Address, targetRng.Address(ReferenceStyle:=xlR1C1))
targetCell.formula = adjustedFormula
End If
Next reference

End Sub

修改后的可行代码 #

直接利用Excel内置的复制粘贴功能，它会自动处理相对引用的调整，比手动解析公式可靠得多：

Sub DuplicateFormulas()
    Dim sourceRng As Range
    Dim targetCell As Range
    Dim targetRng As Range
    
    ' 验证是否选中了单元格区域
    If TypeName(Selection) <> "Range" Then
        MsgBox "请先选择要复制的单元格区域。", vbExclamation
        Exit Sub
    End If
    Set sourceRng = Selection
    
    ' 让用户选择目标起始单元格
    On Error Resume Next
    Set targetCell = Application.InputBox("请选择目标起始单元格：", "复制公式", Type:=8)
    On Error GoTo 0
    
    If Not targetCell Is Nothing Then
        ' 根据源区域大小确定完整的目标区域
        Set targetRng = targetCell.Resize(sourceRng.Rows.Count, sourceRng.Columns.Count)
        
        ' 复制源区域的公式（Excel自动调整相对引用）
        sourceRng.Copy
        targetRng.PasteSpecial Paste:=xlPasteFormulas
        
        ' 可选：复制格式
        sourceRng.Copy
        targetRng.PasteSpecial Paste:=xlPasteFormats
        
        ' 清除剪贴板，避免后续操作受影响
        Application.CutCopyMode = False
        
        MsgBox "公式复制完成！", vbInformation
    End If
End Sub

关键说明 #

• 原代码的问题在于手动逐个单元格赋值公式，再尝试解析调整引用——这种方式不仅复杂，还会遗漏混合引用、数组公式、多单元格引用等复杂场景的处理。
• 修改后的代码直接调用Excel的Copy和PasteSpecial方法：
  1. 用Resize确保目标区域和源区域的行列数完全一致
  2. xlPasteFormulas参数会让Excel自动识别并调整公式中的相对引用，完全符合你的需求（比如原=SUM($B31:H31)会自动变成=SUM($J31:P31)）
  3. 保留了格式复制的功能，和原需求一致
• 支持非连续区域的复制，Excel会自动对应到目标区域的对应位置

效果对比 #

原代码效果（引用未调整） #

修改后效果（引用自动调整） #

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