excel - 将具有唯一值的所有行复制到新工作表，包括标题行

Question

我正在尝试修复代码以将基于列中唯一值的所有行复制到新工作表
1. 表格有一个 A1:CM4 范围内的表头，其中还包括一张小图片
2. 最后一行包含每列 C:CM 的 SUM 公式

试图得到:
1.为A列中的每个唯一值创建新工作表(复制所有适当的行，一些单元格为空)，包括带有图片的标题(A1:CM4)
3.根据唯一值命名新工作表(可以是带有空格和逗号的长名称:“aaaaa and bbbb, cccc”)
4. 最后一行应包含 SUM 公式和每列 C:CM 的格式

我有一个代码可以完成部分工作(创建具有唯一值的新工作表)，但仍在努力解决下一个问题:
1. 不复制所有标题(现在只复制 4 行中的第 1 行)
2. 不保留/复制带有 SUM 公式的最后一行
3. 如果唯一值如下，则不命名工作表:“aaaaa and bbbb, cccc”(不太重要)

Sub unique_data()
Dim RCount As Long
Dim Sht As Worksheet
Dim NSht As Worksheet
Dim I As Long
Dim TRrow As Integer
Dim Col As New Collection
Dim Title As String
Dim SUpdate As Boolean

Set Sht = ActiveSheet
On Error Resume Next
RCount = Sht.Cells(Sht.Rows.Count, 1).End(xlUp).Row - 1
Title = "A1"
TRrow = Sht.Range(Title).Cells(1).Row
For I = 5 To RCount
    Call Col.Add(Sht.Cells(I, 1).Text, Sht.Cells(I, 1).Text)
Next

SUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False

For I = 1 To Col.Count
    Call Sht.Range(Title).AutoFilter(1, CStr(Col.Item(I)))
    Set NSht = Nothing
    Set NSht = Worksheets(CStr(Col.Item(I)))
        If NSht Is Nothing Then
            Set NSht = Worksheets.Add(, Sheets(Sheets.Count))
            NSht.Name = CStr(Col.Item(I))
        Else
            NSht.Move , Sheets(Sheets.Count)
        End If
    Sht.Range("A" & TRrow & ":A" & RCount).EntireRow.Copy NSht.Range("A1")
    NSht.Columns.AutoFit
Next

Sht.AutoFilterMode = False
Sht.Activate
Application.ScreenUpdating = SUpdate
MsgBox "All done!", vbExclamation
End Sub

非常感谢您的帮助!

Answer 1

我设法修复了我的代码并获得了正确的结果(在命名电子表格方面仍然存在一些问题，因为有些名称相当长并且 excel 不会用它们来命名选项卡)，但无论如何，这就是代码正在做的事情:
1.创建新的电子表格并根据主工作表特定范围(A5:..)内的唯一值复制适当的行
2.根据唯一值重命名新电子表格
3. 将所有标题行 (4) 复制到新电子表格
4. 用 SUM 公式复制最后一行，并根据返回的记录数调整每个电子表格的总和范围
5. 格式化新的电子表格

我希望有人可以使用此代码来解决类似的难题，或者让它更有效率。

Sub unique_data()

Dim RCount As Long
Dim Sht As Worksheet
Dim NSht As Worksheet
Dim I As Long
Dim Col As New Collection
Dim SUpdate As Boolean
Dim Lrow As Long
Dim NShtLR As Long

Set Sht = ActiveSheet
On Error Resume Next
RCount = Sht.Cells(Sht.Rows.Count, 1).End(xlUp).Row - 1
Lrow = Sht.Cells(Sht.Rows.Count, 1).End(xlUp).Row

For I = 5 To RCount
    Call Col.Add(Sht.Cells(I, 1).Text, Sht.Cells(I, 1).Text)
Next

SUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False

For I = 1 To Col.Count
    Call Sht.Range("A5").AutoFilter(1, CStr(Col.Item(I)))
    Set NSht = Nothing
    Set NSht = Worksheets(CStr(Col.Item(I)))
        If NSht Is Nothing Then
            Set NSht = Worksheets.Add(, Sheets(Sheets.Count))
            NSht.Name = CStr(Col.Item(I))
        Else
            NSht.Move , Sheets(Sheets.Count)
        End If
    Sht.Range("A5:A" & RCount).EntireRow.Copy NSht.Range("A5")
Next

Sheets.FillAcrossSheets Sht.Range("1:4")

For Each NSht In Worksheets
    If Not NSht.Name = "MainReport" Then
        NSht.Select
        NShtLR = NSht.Cells(Sht.Rows.Count, 1).End(xlUp).Row + 1
        Sht.Range("A" & Lrow).EntireRow.Copy NSht.Range("A" & NShtLR)
        NSht.Range("C" & NShtLR).Formula = "=SUM(C5:C" & NShtLR - 1 & ")"

        Range("C" & NShtLR).Copy Range("C" & NShtLR & ":CM" & NShtLR)

        Rows("4:4").RowHeight = 230
        Columns("A:A").ColumnWidth = 28
        Columns("B:B").ColumnWidth = 29
        Columns("C:C").ColumnWidth = 3
        Columns("D:CB").ColumnWidth = 3.5
        Columns("CC:CM").ColumnWidth = 4

        NSht.Shapes.Range(Array("Picture 1")).Select
        Selection.ShapeRange.IncrementLeft -3.6
        Selection.ShapeRange.IncrementTop 47.4

        Rows.EntireRow.Hidden = False
        ActiveWindow.Zoom = 70
     End If
Next

Sht.AutoFilterMode = False
Sht.Activate
Application.ScreenUpdating = SUpdate
MsgBox "All done!", vbExclamation
End Sub