使用VBA将多工作表数据填充至新表空白列实现合并

• 需求：将ROSTER CS、ROSTER STARS、ROSTER TU三个工作表的数据合并到NEW ROSTER TEST工作表。数据结构规则：
  • A列为玩家姓名
  • 第1行是Toon名称（一级表头）
  • 第2行是对应数据类型（cs、stars、tu）的二级表头
  • 每个源工作表对应一种数据类型，数据与Toon名称、玩家姓名一一对应
• 当前进展：已编写两个宏，分别实现单个工作表数据复制到新表和在新表添加空白列的功能，但无法自动将其他工作表的数据填充到对应空白列。需要实现批量将各表数据填充到新表对应列的功能，后续还要处理2个额外工作表。

复制单表数据的宏 #

Dim head_count As Integer
Dim row_count As Integer
Dim col_count As Integer
Dim i As Integer
Dim j As Integer
Dim ws1 As Worksheet
Dim ws2 As Worksheet

Set ws1 = Sheets("ROSTER CS")
Set ws2 = Sheets("NEW ROSTER TEST")

ws2.Activate
head_count = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlToRight)))

ws1.Activate
col_count = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlToRight)))
row_count = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))

For i = 1 To head_count

    j = 1
    
    Do While j <= col_count
    
        If ws2.Cells(1, i) = ws1.Cells(1, j).Text Then
        
            ws1.Range(Cells(1, j), Cells(row_count, j)).Copy
            ws2.Cells(1, i).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            j = col_count
              
        End If
        
        j = j + 1
    
    Loop

Next i

With ws2
    .Activate
    .Cells(1, 1).Select
End With

End Sub

添加3列的宏 #

Sub Add_3_Columns()

    Dim c As Long
    Dim ctr As Long
    Dim lr As Long
    
    Application.ScreenUpdating = False
    
'   Set initial column to start
    c = 3
    
'   Loop through columns
    Do
'       See if any columns to the left of current column (check row 1 for data)
        If Cells(1, c - 1) <> "" Then
'           Find last row in column to the left
            lr = Cells(Rows.Count, c - 1).End(xlUp).Row

'           Insert three columns
            Range(Cells(1, c), Cells(1, c + 2)).EntireColumn.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'           Insert headers
            Cells(2, c).Value = "STARS"
            Cells(2, c + 1).Value = "TU"

'           Jump to next column
            c = c + 4
        Else
'           Exit loop when no more data found
            Exit Do
        End If
    Loop
    
    Application.ScreenUpdating = True

    MsgBox "Macro complete!"

End Sub

下面的宏可一次性处理所有目标源工作表，自动匹配Toon名称和数据类型，将数据填充到NEW ROSTER TEST的对应列，无需手动分步执行添加列和复制数据的操作：

Sub BatchMergeRosterData()
    Dim targetWs As Worksheet
    Dim sourceWs As Worksheet
    Dim sourceDataType As String
    Dim targetLastCol As Long, sourceLastCol As Long, sourceLastRow As Long
    Dim targetRow As Long, targetCol As Long, sourceCol As Long
    Dim toonName As String
    
    ' 设置目标工作表
    Set targetWs = ThisWorkbook.Sheets("NEW ROSTER TEST")
    Application.ScreenUpdating = False
    
    ' 遍历所有需要合并的源工作表
    For Each sourceWs In ThisWorkbook.Sheets
        ' 只处理指定的源工作表（后续添加新表时直接补充表名即可）
        Select Case UCase(sourceWs.Name)
            Case "ROSTER CS", "ROSTER STARS", "ROSTER TU"
                ' 获取当前源工作表对应的数据类型
                sourceDataType = UCase(Replace(sourceWs.Name, "ROSTER ", ""))
                
                ' 获取源工作表的最后列和最后行
                sourceLastCol = sourceWs.Cells(1, sourceWs.Columns.Count).End(xlToLeft).Column
                sourceLastRow = sourceWs.Cells(sourceWs.Rows.Count, 1).End(xlUp).Row
                
                ' 遍历源工作表的每个Toon列（从第2列开始，第1列是玩家姓名）
                For sourceCol = 2 To sourceLastCol
                    toonName = sourceWs.Cells(1, sourceCol).Text
                    
                    ' 在目标工作表中找到匹配的Toon列（一级表头）
                    targetCol = 0
                    On Error Resume Next
                    targetCol = targetWs.Rows(1).Find(What:=toonName, LookIn:=xlValues, LookAt:=xlWhole).Column
                    On Error GoTo 0
                    
                    If targetCol > 0 Then
                        ' 在目标Toon列下找到对应数据类型的二级表头列
                        For targetColOffset = 0 To 2 ' 假设每个Toon最多对应3个数据类型列
                            If UCase(targetWs.Cells(2, targetCol + targetColOffset).Value) = sourceDataType Then
                                ' 复制源数据到目标列（从第2行开始，跳过表头）
                                sourceWs.Range(sourceWs.Cells(2, sourceCol), sourceWs.Cells(sourceLastRow, sourceCol)).Copy
                                targetWs.Cells(2, targetCol + targetColOffset).PasteSpecial xlPasteValues
                                Exit For
                            End If
                        Next targetColOffset
                    End If
                Next sourceCol
        End Select
    Next sourceWs
    
    ' 清理操作并返回目标工作表
    Application.CutCopyMode = False
    targetWs.Activate
    targetWs.Cells(1, 1).Select
    Application.ScreenUpdating = True
    MsgBox "所有数据合并完成！"
End Sub

宏说明 #

1. 扩展性强：后续新增工作表时，只需在Select Case语句中补充对应表名即可
2. 精准匹配：先匹配一级表头（Toon名称），再匹配二级表头（数据类型），确保数据填充到正确位置
3. 高效批量处理：一次性遍历所有源表，省去手动分步执行的繁琐操作
4. 性能优化：关闭屏幕更新，提升宏的运行速度

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