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

Excel文件具有以下工作表结构：

A1

A2

A3

A4

B1

B2

B3

C1

C2

C3

C4

C5

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

我想做的是：

1） 将每种类型（A、B、C等）的工作表的内容分别合并到新创建的摘要工作表中

假设目标结构如下：

AX

A1A2A3A4BXB1

B2

B3

等。， 而

AX

将

A1

的内容汇总到

A4

，

BX

将

B1

的内容汇总到

B3

等

我有以下程序将所有工作表合并到一个汇总表中

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

但是现在我想将这个例程“拆分”，以便创建多个摘要表，如上面基于工作表组的目标结构所示

2） 在下一步中，我将删除除汇总表之外的所有工作表，以便只剩下汇总工作表，如下图所示：

AX

BX

CX

等

---

另外请注意：我确实知道每种类型有多少张纸，例如4xA.3xB等，但是如果可能的话，程序应该自动计算每张纸的数量。谢谢您的提示。

这里是根据您的要求提供的解决方案

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

子联合收割机（）
将ws设置为工作表，将wsD设置为工作表
Dim Dic As Object:Set Dic=CreateObject（“Scripting.Dictionary”）
暗键，我&
Application.DisplayAlerts=False
使用此工作簿
对于每个ws-In.工作表
如果Dic.不存在（UCase（左（ws.Name，1）），则
添加UCase（左（ws.Name，1）），无任何内容
如果结束
下一个ws
对于Dic中的每个键
设置wsD=.Sheets.Add（之后：=_
.Sheets（.Sheets.Count））
wsD.Name=键和“摘要”
i=1
对于每个ws-In.工作表
如果UCase（ws.Name）像key&“*”和_
那么ws.Name键和“Summary”
ws.Activate:ws[A1].CurrentRegion.Offset（1，0）。调整大小（[A1].CurrentRegion.Rows.Count-1）。复制
wsD.Activate:Range（“A”&i）.pasteAll
i=wsD.Cells（Rows.Count，“A”）.End（xlUp）。Row+1
如果结束
下一个ws
下一键
对于每个ws-In.工作表
如果不是像“*Summary”这样的ws.Name，那么
ws.Delete
如果结束
下一个ws
以
Application.DisplayAlerts=True
端接头

更新 无词典变体

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

子组合2（）
将ws作为工作表、wsL作为工作表、wsD作为工作表
尺寸i和cl As范围
Application.DisplayAlerts=False
i=1
使用此工作簿
设置wsL=.Sheets.Add（后面：=.Sheets（.Sheets.Count））
wsL.Name=“列表”
对于每个ws-In.工作表
如果ws.Name是“列表”，那么
Set cl=wsL[A:A].Find（UCase（左（ws.Name，1）））
如果cl什么都不是
Cells（i，1）.Value=UCase（左（ws.Name，1））
i=i+1
如果结束
如果结束
下一个ws
对于wsL[A1].CurrentRegion中的每个cl
设置wsD=.Sheets.Add（之后：=_
.Sheets（.Sheets.Count））
wsD.Name=cl.Value&“摘要”
i=1
对于每个ws-In.工作表
如果UCase（ws.Name）像cl.Value&“*”和_
ws.Name cl.Value&“摘要”和ws.Name“列表”
ws.Activate:ws[A1].CurrentRegion.Offset（1，0）。调整大小（[A1].CurrentRegion.Rows.Count-1）。复制
wsD.Activate:Range（“A”&i）.pasteAll
i=wsD.Cells（Rows.Count，“A”）.End（xlUp）。Row+1
如果结束
下一个ws
下一个cl
对于每个ws-In.工作表
如果不是像“*Summary”这样的ws.Name，那么
ws.Delete
如果结束
下一个ws
以
Application.DisplayAlerts=True
端接头

哇，太快了。工作完美。对于初学者来说，还有一个问题：为什么要使用字典，或者换句话说，它能以不同的方式解决（可能更慢）？@EDC是的，你的任务可以不用字典完成。您需要如何在不使用字典的情况下解决它的示例吗？这对我来说很有意思，但公平地说，我认为没有必要，因为您当前的解决方案工作得很好。@EDC变体（不使用字典）已添加到我的postAwesome中。我非常感谢，非常感谢你的时间和努力：）！