如何修改VBA代码实现多工作表指定区域数据合并至单工作表

需求说明 #

需要改造VBA代码实现以下功能：

• 从多个工作表提取数据，起始区域固定为O7:T7
• 跳过仅包含返回空文本公式的无数据工作表
• 仅当O7:T7存在有效数据时，复制后续所有非空行（无空行）

同时需解决当前代码的三个问题：

• 添加多工作表排除条件
• 识别不含空文本公式的最后有效数据行
• 仅复制有效值，使用选择性粘贴而非复制公式

改造后的完整代码 #

Option Explicit
Public Sub CombineDataFromAllSheets()

    Dim wksSrc As Worksheet, wksDst As Worksheet
    Dim rngSrc As Range, rngDst As Range
    Dim lngSrcLastRow As Long, lngDstLastRow As Long
    Dim excludeSheets As Variant
    Dim isSheetExcluded As Boolean
    
    ' 定义需要排除的工作表列表，可自行添加更多表名
    excludeSheets = Array("Template", "LIST")
    
    ' 初始化目标工作表
    Set wksDst = ThisWorkbook.Worksheets("AOD")
    lngDstLastRow = LastValidRowNum(wksDst)
    Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)
    
    ' 遍历所有工作表
    For Each wksSrc In ThisWorkbook.Worksheets
        ' 检查当前工作表是否在排除列表中
        isSheetExcluded = False
        Dim sheetName As Variant
        For Each sheetName In excludeSheets
            If wksSrc.Name = sheetName Then
                isSheetExcluded = True
                Exit For
            End If
        Next sheetName
        
        If Not isSheetExcluded Then
            ' 判断起始区域是否存在有效数据（跳过空文本公式）
            If Application.WorksheetFunction.CountA(wksSrc.Range("O7:T7")) > 0 Then
                ' 获取O列最后有有效数据的行
                lngSrcLastRow = wksSrc.Range("O" & wksSrc.Rows.Count).End(xlUp).Row
                
                ' 确保需要复制的行范围有效
                If lngSrcLastRow >= 7 Then
                    ' 定义完整的数据源范围
                    Set rngSrc = wksSrc.Range("O7:T" & lngSrcLastRow)
                    
                    ' 选择性粘贴值和格式，避免复制公式
                    rngSrc.Copy
                    rngDst.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                    Application.CutCopyMode = False ' 清除剪贴板状态
                    
                    ' 更新目标区域的起始位置
                    lngDstLastRow = LastValidRowNum(wksDst)
                    Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)
                End If
            End If
        End If
    Next wksSrc
    
    MsgBox "数据合并完成！", vbInformation
End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 功能：获取工作表中最后一行有有效数据的行号（忽略空文本公式）
' 输入：目标工作表对象
' 输出：最后有效行号，工作表为空时返回1
Public Function LastValidRowNum(Sheet As Worksheet) As Long
    Dim lng As Long
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        ' 从底部向上定位最后一个非空行
        lng = Sheet.Cells(Sheet.Rows.Count, "A").End(xlUp).Row
        ' 校验并跳过仅含空文本的行
        Do While lng > 1 And Application.WorksheetFunction.CountA(Sheet.Rows(lng)) = 0
            lng = lng - 1
        Loop
    Else
        lng = 1
    End If
    LastValidRowNum = lng
End Function

关键修改细节 #

1. 多工作表排除机制 #

• 使用数组excludeSheets存储需要排除的工作表名称，支持批量添加/删除，扩展性更强
• 通过循环遍历数组判断当前工作表是否需要跳过，替代原单一条件判断

2. 有效数据行识别 #

• 替换原LastOccupiedRowNum函数为LastValidRowNum，利用CountA统计非空单元格，自动忽略返回空文本的公式
• 针对数据起始列（O列）使用End(xlUp)定位最后有效行，确保只统计有实际内容的行

3. 选择性粘贴实现 #

• 先通过CountA(wksSrc.Range("O7:T7")) > 0判断起始区域是否有有效数据，无数据则直接跳过当前工作表
• 使用xlPasteValuesAndNumberFormats参数粘贴值和格式，彻底避免复制原工作表的公式
• 复制后清除剪贴板状态，防止干扰后续操作

4. 空数据工作表过滤 #

• 结合起始区域的有效性判断，自动跳过仅包含空文本公式的工作表，无需额外判断逻辑

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