根据特定的名称结构组合工作表

Question

Excel 文件具有以下工作结构sheets:

A1 A2 A3 A4 B1 B2 B3 C1 C2 C3 C4 C5 ...

所以你可以看到 4 次 A、3 次 B、5 次 C 等等（没有均匀分布）

我想做的事情：

1) 将各类型（A、B、C等）作品sheet的内容分别合并到新建的摘要作品sheet中。

假设以下是目标结构： AX A1 A2 A3 A4 BX B1 B2 B3 等等，而AX总结了A1到A4的内容，BX总结了B1到B3的内容，依此类推。

我有以下例程将所有工作 sheet 合并为一个摘要 sheet.

Sub Combine()    
Dim i As Integer

On Error Resume Next
Sheets(1).Select
Worksheets.Add
Sheets(1).name = "XXX"
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For i = 2 To Sheets.Count
    Sheets(i).Activate
    Range("A1").Select
    Selection.CurrentRegion.Select
    Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
    Selection.Copy Destination:=Sheets(1).Cells(Sheets(1).Rows.Count, "A").End(xlUp)(2)
Next    
End Sub

但现在我想'split'这个例程，以便创建多个摘要sheets，如上述基于工作sheet组的目标结构。

2) 下一步我想删除除摘要sheet之外的所有工作sheet，这样唯一剩下的就是摘要工作sheets，如下图：

AXBXCX等

作为附加说明：我确实知道每种类型有多少 sheet，例如 4 x A. 3 x B 等，但如果可能，程序应该计算 sheets 自动。感谢您的任何提示。

Answer 1

此处根据您的要求提供解决方案

Sub combine()
Dim ws As Worksheet, wsD As Worksheet
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Dim key, i&
Application.DisplayAlerts = False
With ThisWorkbook
    For Each ws In .Worksheets
        If Not Dic.exists(UCase(Left(ws.Name, 1))) Then
            Dic.Add UCase(Left(ws.Name, 1)), Nothing
        End If
    Next ws
    For Each key In Dic
    Set wsD = .Sheets.Add(After:= _
                 .Sheets(.Sheets.Count))
      wsD.Name = key & " Summary"
      i = 1
        For Each ws In .Worksheets
            If UCase(ws.Name) Like key & "*" And _
                ws.Name <> key & " Summary" Then
                ws.Activate: ws.[A1].CurrentRegion.Offset(1, 0).Resize([A1].CurrentRegion.Rows.Count - 1).Copy
                wsD.Activate: Range("A" & i).PasteSpecial xlPasteAll
                i = wsD.Cells(Rows.Count, "A").End(xlUp).Row + 1
            End If
        Next ws
    Next key
    For Each ws In .Worksheets
        If Not ws.Name Like "* Summary" Then
            ws.Delete
        End If
    Next ws
End With
Application.DisplayAlerts = True
End Sub

更新

没有字典的变体

Sub combine2()
Dim ws As Worksheet, wsL As Worksheet, wsD As Worksheet
Dim i&, cl As Range
Application.DisplayAlerts = False
i = 1
With ThisWorkbook
    Set wsL = .Sheets.Add(After:=.Sheets(.Sheets.Count))
    wsL.Name = "List"
    For Each ws In .Worksheets
        If ws.Name <> "List" Then
            Set cl = wsL.[A:A].Find(UCase(Left(ws.Name, 1)))
            If cl Is Nothing Then
                wsL.Cells(i, 1).Value = UCase(Left(ws.Name, 1))
                i = i + 1
            End If
        End If
    Next ws
    For Each cl In wsL.[A1].CurrentRegion
        Set wsD = .Sheets.Add(After:= _
                     .Sheets(.Sheets.Count))
          wsD.Name = cl.Value & " Summary"
        i = 1
        For Each ws In .Worksheets
            If UCase(ws.Name) Like cl.Value & "*" And _
                ws.Name <> cl.Value & " Summary" And ws.Name <> "List" Then
                ws.Activate: ws.[A1].CurrentRegion.Offset(1, 0).Resize([A1].CurrentRegion.Rows.Count - 1).Copy
                wsD.Activate: Range("A" & i).PasteSpecial xlPasteAll
                i = wsD.Cells(Rows.Count, "A").End(xlUp).Row + 1
            End If
        Next ws
    Next cl
    For Each ws In .Worksheets
        If Not ws.Name Like "* Summary" Then
            ws.Delete
        End If
    Next ws
End With
Application.DisplayAlerts = True
End Sub

根据特定的名称结构组合工作表

Combine Worksheets based on certain name structure

excel

vba

loops

worksheet

更新