Excel工作表重复数据处理及跨表数据导入VBA问题求助

需求回顾 #

• 源工作表TEST的B1:B10为目标工作表名称，对应每行C:E区域的数据需转置后垂直写入目标工作表的D列。
• 若B列中存在重复的工作表名称，除了写入当前行的C:E转置数据外，还需将该目标工作表的A1:E10区域数据复制追加到表的末尾。
• 当前VBA代码无法正确处理不连续的重复工作表名称，存在逻辑错误。

现有代码的核心问题 #

1. 过程命名不合法：Sub extracts data to sheet()包含空格，不符合VBA命名规范，会导致编译错误。
2. 转置写入位置错误：每次都将数据写入目标表的D1开始位置，后续数据会覆盖之前的内容，未找到D列的最后一行进行追加。
3. 重复项处理逻辑缺失：遇到重复工作表名称时，仅执行了复制A1:E10追加的操作，未处理当前行的C:E数据转置写入，不符合需求。
4. 工作表存在性检查冗余：sheetExists变量的判断可以简化，无需额外赋值。

修正后的VBA代码 #

Sub ExtractDataToSheet()
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim selectedSheetName As String
    Dim lastRowD As Long
    Dim lastRowTarget As Long
    Dim i As Long
    Dim duplicateDict As Object
    
    ' 绑定源工作表
    Set sourceSheet = ThisWorkbook.Sheets("TEST")
    ' 创建字典记录已处理过的工作表名称
    Set duplicateDict = CreateObject("Scripting.Dictionary")
    
    ' 遍历B1:B10的工作表名称
    For i = 1 To 10
        selectedSheetName = sourceSheet.Cells(i, 2).Value
        
        ' 跳过空单元格
        If selectedSheetName = "" Then GoTo NextLoop
        
        ' 检查目标工作表是否存在
        On Error Resume Next
        Set targetSheet = ThisWorkbook.Sheets(selectedSheetName)
        On Error GoTo 0
        
        If targetSheet Is Nothing Then
            MsgBox "执行失败：未找到工作表 [" & selectedSheetName & "]", vbExclamation
            Exit Sub
        End If
        
        ' 处理当前行C:E数据转置写入目标表D列
        lastRowD = targetSheet.Cells(targetSheet.Rows.Count, "D").End(xlUp).Row
        ' 如果D列无数据，从第1行开始；否则从下一行开始
        If lastRowD = 1 And targetSheet.Cells(1, "D") = "" Then
            lastRowD = 0
        End If
        sourceSheet.Range("C" & i & ":E" & i).Copy
        targetSheet.Cells(lastRowD + 1, "D").PasteSpecial Paste:=xlPasteValues, Transpose:=True
        Application.CutCopyMode = False
        
        ' 处理重复工作表名称的追加逻辑
        If duplicateDict.Exists(selectedSheetName) Then
            ' 复制目标表A1:E10并追加到末尾
            lastRowTarget = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row + 1
            targetSheet.Range("A1:E10").Copy targetSheet.Cells(lastRowTarget, "A")
            Application.CutCopyMode = False
        Else
            ' 首次处理，将工作表名称加入字典
            duplicateDict(selectedSheetName) = True
        End If
        
NextLoop:
    Next i
    
    MsgBox "数据处理完成", vbInformation
End Sub

代码说明 #

1. 合法命名：将过程名改为ExtractDataToSheet，符合VBA标识符规范。
2. 正确的写入位置：通过lastRowD获取目标表D列的最后一行，确保每次转置数据都追加到D列的末尾，不会覆盖原有内容。
3. 完整的重复项处理：遇到重复工作表名称时，先写入当前行的C:E转置数据，再执行A1:E10的追加操作，完全符合需求。
4. 空值处理：跳过B列的空单元格，避免不必要的错误。
5. 简化工作表检查：直接通过targetSheet Is Nothing判断工作表是否存在，逻辑更简洁。

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