如何实现Excel同名工作表间PivotTable值的精准复制？

原代码核心问题 #

• 循环逻辑错误：遍历data.xlsm的每个工作表后，又遍历District.xlsm的所有工作表粘贴，导致所有透视表被复制到每个目标工作表
• 依赖Activate/Select操作，导致行号（LR）获取错误，代码稳定性差
• SheetExists函数参数错误，未使用传入的工作簿对象，而是固定引用wbook

修正后的VBA代码 #

Sub CopyPivotValuesToSameSheets()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Dim dataBook As Workbook
    Dim districtBook As Workbook
    Dim dataSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim pivotTable As PivotTable
    Dim nextEmptyRow As Long
    Dim i As Integer
    
    ' 绑定两个工作簿对象
    Set dataBook = Workbooks("data.xlsm")
    Set districtBook = Workbooks("District.xlsm")
    
    ' 遍历data.xlsm的每个工作表
    For Each dataSheet In dataBook.Worksheets
        ' 检查District.xlsm中是否存在同名工作表
        If SheetExists(dataSheet.Name, districtBook) Then
            Set targetSheet = districtBook.Worksheets(dataSheet.Name)
            
            ' 清空目标工作表内容
            targetSheet.Cells.ClearContents
            
            ' 遍历当前工作表的9个透视表
            For i = 1 To 9
                On Error Resume Next ' 处理透视表不存在的情况
                Set pivotTable = dataSheet.PivotTables("PivotTable" & i)
                On Error GoTo 0
                
                If Not pivotTable Is Nothing Then
                    ' 获取目标表的下一个空行（A列）
                    nextEmptyRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row
                    ' 处理首行空的情况
                    If nextEmptyRow = 1 And targetSheet.Cells(1, 1).Value = "" Then
                        nextEmptyRow = 1
                    Else
                        nextEmptyRow = nextEmptyRow + 1
                    End If
                    
                    ' 复制透视表并粘贴为值和数字格式
                    pivotTable.PivotSelect "", xlDataAndLabel, True
                    Selection.Copy
                    targetSheet.Range("A" & nextEmptyRow).PasteSpecial xlPasteValuesAndNumberFormats
                    Application.CutCopyMode = False ' 清除复制状态
                End If
            Next i
            
            ' 自动调整目标工作表列宽
            targetSheet.UsedRange.Columns.AutoFit
        End If
    Next dataSheet
    
    MsgBox "操作完成！"
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

' 修正后的工作表存在性检查函数
Function SheetExists(strName As String, wkbS As Workbook) As Boolean
    Dim sh As Worksheet
    On Error Resume Next
    Set sh = wkbS.Worksheets(strName)
    SheetExists = (Err = 0)
    On Error GoTo 0
End Function

关键修改点 #

• 通过工作表名称直接匹配目标表，避免无效遍历
• 移除Activate/Select操作，改用对象引用，提升代码稳定性和运行效率
• 修正SheetExists函数的参数错误，确保正确检查目标工作簿中的工作表
• 动态计算目标表的下一个空行，避免内容覆盖
• 增加错误处理，防止因透视表不存在导致代码中断
• 对每个目标工作表单独调整列宽，而非仅针对Northland表

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