基于特定的名称结构组合工作表

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

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

所以你可以看到4次A,3次B,5次C等(不均匀分布)

我想做什么:

1)将每种types的工作表(A,B,C等)的内容分别合并到新创build的总结工作表中。

我们假设以下是目标结构: AX A1 A2 A3 A4 BX B1 B2 B3等,而AX总结了A1A4的内容, BX总结了B1B3等的内容。

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

 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 

但是现在我想“拆分”这个例程,以便根据工作表组创build多个汇总表,如上面的目标结构。

2)在接下来的步骤中,我想删除汇总表以外的所有工作表,以便唯一保留的是汇总工作表,如下图所示:

AX BX CX

作为附加说明:我知道每种types的纸张数量,例如4×3×B等,但是如果可能的话,程序应该自动计算纸张的数量。 感谢任何提示。

这里的解决scheme根据您的要求

 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