Excel VBA复制数据到多工作表忽略公式仅粘贴值的实现方法

问题原因 #

你遇到的循环引用报错是因为原代码用.Copy方法会复制源区域的所有内容（包含公式、格式等），粘贴到模板工作表后，公式的引用关系和模板原有公式形成循环，触发报错。

优化后完整代码 #

Sub FC()
    Dim wkSht As Worksheet
    Dim cell As Range
    Dim sourceRng As Range
    ' 定义列映射关系：数组第一项为汇总表相对当前行的偏移列数，第二项为模板表目标列标
    ' 可根据需求新增多组对应关系，示例默认保留原需求：偏移18列传到O列
    Dim colMap As Variant
    colMap = Array( _
        Array(18, "O"), _
        Array(2, "A"), _ ' 示例：可新增，汇总表偏移2列传到模板表A列
        Array(5, "C") _ ' 示例：汇总表偏移5列传到模板表C列
    )
    Dim mapItem As Variant
    
    Application.ScreenUpdating = False ' 关闭屏幕刷新提升运行速度
    
    For Each cell In Sheets("Combine").Range("A4:A600").Cells
        ' 跳过A列空行，避免无效遍历
        If cell.Value = "" Then GoTo NextCell
        
        ' 匹配同名工作表
        For Each wkSht In ThisWorkbook.Worksheets
            If wkSht.Name = cell.Value Then
                ' 遍历所有列映射关系，批量传输多列数据
                For Each mapItem In colMap
                    ' 定义源区域：当前行偏移指定列，共19行（0到18偏移）1列
                    Set sourceRng = Sheets("Combine").Range(cell.Offset(0, mapItem(0)), cell.Offset(18, mapItem(0)))
                    ' 直接赋值仅传数值，不使用剪贴板，效率更高无公式问题
                    wkSht.Range(mapItem(1) & "17").Resize(sourceRng.Rows.Count, sourceRng.Columns.Count).Value = sourceRng.Value
                Next mapItem
                Exit For ' 匹配到对应工作表后直接退出循环，提升效率
            End If
        Next wkSht
NextCell:
    Next cell
    
    Application.ScreenUpdating = True ' 恢复屏幕刷新
End Sub

代码说明 #

• 仅粘贴数值实现：采用区域直接赋值的方式替代Copy方法，仅传输单元格的数值内容，不会带入公式，从根源解决循环引用问题，同时不会占用系统剪贴板，运行效率更高。
• 多列匹配传输实现：通过colMap数组自定义列映射规则，只需按照Array(汇总表偏移列数, 模板表目标列标)的格式新增数组项，即可实现多列数据批量对应传输，不需要重复写复制逻辑。
• 工作表名称匹配：保留原有的cell.Value = wkSht.Name精确匹配逻辑，要求汇总表A列的名称和工作表名称完全一致（包含大小写、空格、特殊符号），如果需要模糊匹配可以修改判断条件。
• 如果你习惯用粘贴值的写法，可以将直接赋值的代码替换为以下内容，效果一致：

  sourceRng.Copy
  wkSht.Range(mapItem(1) & "17").PasteSpecial xlPasteValues
  Application.CutCopyMode = False ' 清空剪贴板
  

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