Excel VBA宏需求：跨工作表粘贴链接时设置对应字体颜色

需求说明 #

我已复制一个单元格区域，需以粘贴链接方式粘贴，且公式需转换为行绝对、列相对引用。手动选择目标区域后，要求：

• 目标区域在其他工作表时，字体设为蓝色
• 目标区域在当前工作表时，字体设为绿色

现有宏已实现粘贴链接、公式转换及蓝色字体设置，但无法判断源/目标工作表并设置对应颜色，请求修改。

原宏代码 #

Sub PasteLink_Array_Blue_Green()
    
    Dim rng As Range
    Dim arr As Variant
    Dim i As Long, j As Long
    
            ' Paste the links into the currently active sheet
    activeSheet.Paste Link:=True

            ' Preserve source formatting
    rng.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
            ' Store the selection in a range object
       

   Set rng = Selection

            ' Convert the formulas to an array
    arr = rng.formula

            ' Loop through the array and convert each formula
    For i = LBound(arr, 1) To UBound(arr, 1)
        For j = LBound(arr, 2) To UBound(arr, 2)
            If IsArray(arr(i, j)) Then
                arr(i, j) = Application.ConvertFormula(arr(i, j)(1, 1), xlA1, xlA1, xlAbsRowRelColumn)
            Else
                arr(i, j) = Application.ConvertFormula(arr(i, j), xlA1, xlA1, xlAbsRowRelColumn)
            End If
        Next j
    Next i

            ' Apply the converted formulas back to the range

    rng.formula = arr

            ' Change the font color to blue   
    rng.Font.Color = RGB(0, 0, 255)

End Sub

修改后的宏代码 #

Sub PasteLink_Array_Blue_Green()
    Dim rng As Range
    Dim arr As Variant
    Dim i As Long, j As Long
    Dim sourceSheetName As String
    Dim targetSheetName As String
    
    ' 记录目标工作表名称
    targetSheetName = ActiveSheet.Name
    
    ' 粘贴链接到当前活动工作表
    ActiveSheet.Paste Link:=True
    
    ' 保存选择的目标区域
    Set rng = Selection
    
    ' 保留源单元格格式
    rng.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
    ' 从第一个单元格公式中解析源工作表名称
    If rng.Cells(1, 1).HasFormula Then
        ' 兼容带空格的工作表名称格式（如'销售数据'!A1）
        If InStr(rng.Cells(1, 1).Formula, "'!") > 0 Then
            sourceSheetName = Mid(rng.Cells(1, 1).Formula, 2, InStr(rng.Cells(1, 1).Formula, "'!") - 2)
        ElseIf InStr(rng.Cells(1, 1).Formula, "!") > 0 Then
            sourceSheetName = Mid(rng.Cells(1, 1).Formula, 1, InStr(rng.Cells(1, 1).Formula, "!") - 1)
        End If
    End If
    
    ' 将公式存入数组批量处理
    arr = rng.Formula
    
    ' 遍历数组转换公式为行绝对、列相对引用
    For i = LBound(arr, 1) To UBound(arr, 1)
        For j = LBound(arr, 2) To UBound(arr, 2)
            If IsArray(arr(i, j)) Then
                arr(i, j) = Application.ConvertFormula(arr(i, j)(1, 1), xlA1, xlA1, xlAbsRowRelColumn)
            Else
                arr(i, j) = Application.ConvertFormula(arr(i, j), xlA1, xlA1, xlAbsRowRelColumn)
            End If
        Next j
    Next i
    
    ' 应用转换后的公式到目标区域
    rng.Formula = arr
    
    ' 判断源表与目标表是否一致，设置对应字体颜色
    If sourceSheetName = targetSheetName Then
        ' 同工作表：绿色字体
        rng.Font.Color = RGB(0, 128, 0)
    Else
        ' 不同工作表：蓝色字体
        rng.Font.Color = RGB(0, 0, 255)
    End If
End Sub

关键修改点 #

1. 修复原代码逻辑错误：调整了Set rng = Selection的顺序，避免未赋值就执行PasteSpecial导致报错
2. 新增源工作表解析：从目标区域第一个单元格的公式中提取源表名，兼容带空格的表名格式
3. 添加工作表判断逻辑：对比源表与目标表名称，根据结果设置对应字体颜色
4. 优化代码注释：将英文注释改为中文，提升可读性

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