Excel文件具有以下工作表结构:
A1
A2
A3
A4
B1
B2
B3
C1
C2
{{ 1}} C3
C4
...
因此,您可以看到4次A,3次B,5次C等(无均匀分布)
我想做什么:
1)将每种类型的工作表(A,B,C等)的内容分别合并到新创建的摘要工作表中。
所以让我们说以下是目标结构:
C5
AX
A1
A2
A3
A4
BX
B1
B2
等,
而B3
总结了AX
到A1
的内容,而A4
总结了BX
到B1
的内容,等等。
我有以下例程将所有工作表合并到一个摘要表中。
B3
但是现在我想“拆分”这个例程,以便根据工作表组创建多个汇总表,就像在上面的目标结构中一样。
2)在下一步中,我想删除除摘要表之外的所有工作表,以便剩下的唯一内容是摘要工作表,如下图所示:
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
AX
BX
等。
作为补充说明:我确实知道每种类型的纸张数量,例如4 x A. 3 x B等,但如果可能,程序应自动计算纸张数量。感谢任何提示。
答案 0 :(得分: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