VBA批量复制数据时YearMonth与SourceSheet列数据溢出问题排查

核心问题分析 #

代码中YearMonth和SourceSheet列数据溢出的根源是错误使用UsedRange获取输入表数据范围：

• UsedRange会包含工作表中所有曾经被编辑过的单元格（哪怕当前是空值），导致dataRange可能夹带大量空行。
• 基于dataRange.Rows.Count计算的dataLastRow被高估，填充SourceSheet/YearMonth时会覆盖到空行区域；后续的ClearContents操作无法精准清理冗余数据，残留内容会延续到非数据行。

此外还有两处低效冗余问题：

• 每次循环重复查找YearMonth列，完全可以移到循环外仅执行一次。
• 每次循环后清空SourceSheet/YearMonth列的所有下方单元格，既浪费资源，也可能干扰后续数据添加。

修正后的代码 #

Sub CopyDataToDataSheet()
    Dim dataSheet As Worksheet
    Dim inputSheet As Worksheet
    Dim calculationSheet As Worksheet
    Dim lastRow As Long
    Dim yearMonthValue As Variant
    Dim yearMonthColumn As Range
    Dim sourceSheetColumn As Range
    Dim dataRange As Range
    Dim sourceSheetNames As Variant
    Dim inputLastRow As Long
    Dim dataLastRow As Long
    
    ' 初始化目标表和计算表
    Set dataSheet = ThisWorkbook.Worksheets("Data Archive")
    Set calculationSheet = ThisWorkbook.Worksheets("Calculation")
    
    ' 取消目标表的筛选
    If dataSheet.AutoFilterMode Then
        dataSheet.AutoFilterMode = False
    End If
    
    ' 一次性查找SourceSheet和YearMonth列（仅执行一次）
    Set sourceSheetColumn = dataSheet.Rows(1).Find("SourceSheet", LookIn:=xlValues, LookAt:=xlWhole)
    Set yearMonthColumn = dataSheet.Rows(1).Find("YearMonth", LookIn:=xlValues, LookAt:=xlWhole)
    
    ' 获取YearMonth值（仅读取一次）
    yearMonthValue = calculationSheet.Range("F1").Value
    
    ' 遍历输入表
    sourceSheetNames = Array("sheet1", "sheet2", "sheet3", "sheet4")
    For Each inputSheet In ThisWorkbook.Worksheets(sourceSheetNames)
        ' 获取目标表当前最后数据行（基于列A）
        lastRow = dataSheet.Cells(dataSheet.Rows.Count, "A").End(xlUp).Row
        
        ' 获取输入表的真实最后数据行（避免UsedRange的空行问题）
        inputLastRow = inputSheet.Cells(inputSheet.Rows.Count, "A").End(xlUp).Row
        ' 仅复制表头下的有效数据（若输入表无数据则跳过）
        If inputLastRow > 1 Then
            Set dataRange = inputSheet.Range("A2:" & inputSheet.Cells(inputLastRow, inputSheet.UsedRange.Columns.Count).Address)
            dataRange.Copy dataSheet.Cells(lastRow + 1, "A")
            
            ' 计算新增数据的最后行
            dataLastRow = lastRow + dataRange.Rows.Count
            
            ' 填充SourceSheet列
            If Not sourceSheetColumn Is Nothing Then
                dataSheet.Range(dataSheet.Cells(lastRow + 1, sourceSheetColumn.Column), _
                               dataSheet.Cells(dataLastRow, sourceSheetColumn.Column)).Value = inputSheet.Name
            End If
            
            ' 填充YearMonth列
            If Not yearMonthColumn Is Nothing Then
                dataSheet.Range(dataSheet.Cells(lastRow + 1, yearMonthColumn.Column), _
                               dataSheet.Cells(dataLastRow, yearMonthColumn.Column)).Value = yearMonthValue
            End If
        End If
    Next inputSheet
    
    MsgBox "Data imported successfully."
End Sub

关键修正点说明 #

• 替换UsedRange为真实数据范围：通过inputSheet.Cells(inputSheet.Rows.Count, "A").End(xlUp).Row获取输入表的有效最后行，确保复制的dataRange仅包含实际有数据的行。
• 提前执行列查找和值读取：将SourceSheet/YearMonth列的查找、YearMonth值的读取移到循环外，避免重复操作，提升效率。
• 移除不必要的ClearContents操作：精准计算dataLastRow后，仅填充新增的有效数据行，无需清空整列下方，避免误删或残留问题。
• 增加空数据判断：若输入表无数据（inputLastRow <=1），则跳过该表的复制操作，避免无效执行。

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