Excel文件的工作表结构如下:
A1
A2
A3
A4
B1
B2
B3
C1
C2
C3
C4
C5
…
所以你可以看到4倍A, 3倍B, 5倍C等等(没有均匀分布)
我想做什么:
1)将每种类型(A、B、C等)的工作表的内容分别合并到新创建的摘要工作表中。
假设下面是目标结构:AX
A1
A2
A3
A4
BX
B1
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
等
作为附加说明:我确实知道每种类型有多少张纸,例如4 xa 3 x B等,但如果可能的话,程序应该自动计算纸的数量。谢谢你的提示。
根据您的需求提供解决方案
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
标题>