Excel跨工作表带格式粘贴失败：单元格尺寸不匹配求助

问题场景 #

需要将包含多个表格的Excel工作表中的部分表格复制到另一个空白工作表，但所有复制粘贴方法均报错：源表格的单元格尺寸与目标工作表的单元格不匹配，导致粘贴操作失败。使用的VBA代码如下：

Sub Données_générales()

    Dim feuilleSource As Worksheet
    Dim derniereLigne As Long
    Dim debutTableauLigne As Long
    Dim nb_lignes_tableau As Long
    Dim nb_lignes_total As Long
    
    nb_lignes_total = 0
    
    Set feuilleSource = Workbooks("Indicateurs.xlsx").Sheets("Rapport1")
    
    Windows("Rapport2.xlsm").Activate
    Sheets("Tableaux1").Select
    
    derniereLigne = 20

    For i = 2 To derniereLigne
    
        Dim numero_tableau As Double
        numero_tableau = Val(Cells(i, 4).Value)
    
        nb_lignes_tableau = Cells(i, 8).Value
        
        debutTableauLigne = feuilleSource.Columns(1).Find(numero_tableau, LookIn:=xlValues, LookAt:=xlWhole).Row
        
        feuilleSource.Rows(debutTableauLigne).Resize(nb_lignes_tableau).Copy
        
        ThisWorkbook.Sheets("Données").Activate
        
        ThisWorkbook.Sheets("Données").Cells(nb_lignes_total + 1, 2).PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        
        ThisWorkbook.Sheets("Données").Cells(nb_lignes_total + 1, 2).PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
        
        nb_lignes_total = nb_lignes_total + nb_lignes_tableau
    Next i
    
    
End Sub

问题根源及修复方案 #

1. 核心问题分析 #

• 频繁使用Activate和Select切换工作表，容易导致上下文混乱，引发区域引用错误；
• 复制整行（Rows）后粘贴到单一单元格，源区域是整行（多列）而目标仅指定起始单元格，若源表与目标表的列宽、行高设置不一致，就会触发尺寸不匹配报错；
• 两次PasteSpecial操作增加了出错概率，且效率较低。

2. 修复后的代码 #

Sub Données_générales()
    Dim feuilleSource As Worksheet
    Dim feuilleCible As Worksheet
    Dim feuilleParam As Worksheet
    Dim derniereLigne As Long
    Dim debutTableauLigne As Long
    Dim nb_lignes_tableau As Long
    Dim nb_lignes_total As Long
    Dim numero_tableau As Double
    Dim i As Long
    Dim findResult As Range
    Dim sourceRange As Range
    Dim targetRange As Range
    
    nb_lignes_total = 0
    
    ' 直接绑定工作表对象，无需激活切换
    Set feuilleSource = Workbooks("Indicateurs.xlsx").Sheets("Rapport1")
    Set feuilleParam = ThisWorkbook.Sheets("Tableaux1")
    Set feuilleCible = ThisWorkbook.Sheets("Données")
    
    derniereLigne = 20

    For i = 2 To derniereLigne
        numero_tableau = Val(feuilleParam.Cells(i, 4).Value)
        nb_lignes_tableau = feuilleParam.Cells(i, 8).Value
        
        ' 查找表格起始行，增加不存在判断避免崩溃
        Set findResult = feuilleSource.Columns(1).Find(numero_tableau, LookIn:=xlValues, LookAt:=xlWhole)
        If findResult Is Nothing Then
            MsgBox "未找到表格编号: " & numero_tableau, vbExclamation
            Continue For
        End If
        debutTableauLigne = findResult.Row
        
        ' 指定复制的列范围（示例为A-Z，可根据实际表格列数调整）
        Set sourceRange = feuilleSource.Range("A" & debutTableauLigne & ":Z" & debutTableauLigne + nb_lignes_tableau - 1)
        
        ' 匹配目标区域尺寸，确保与源区域完全一致
        Set targetRange = feuilleCible.Cells(nb_lignes_total + 1, 2).Resize(sourceRange.Rows.Count, sourceRange.Columns.Count)
        
        ' 直接赋值数据，比粘贴更高效稳定
        targetRange.Value = sourceRange.Value
        ' 复制格式
        sourceRange.Copy
        targetRange.PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
        
        nb_lignes_total = nb_lignes_total + nb_lignes_tableau
    Next i
End Sub

3. 关键优化点 #

• 移除所有Activate/Select操作，直接通过工作表对象引用单元格，彻底避免上下文混乱；
• 明确指定复制的列范围，替换整行复制，消除因行列尺寸差异导致的报错；
• 增加查找结果的空值判断，避免找不到表格编号时代码崩溃；
• 用直接赋值替代xlPasteValues，提升运行效率同时降低出错概率。

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