Question

我正在尝试修复代码，以将基于列中唯一值的所有行复制到新工作表中。
1.该表的标题在A1：CM4范围内，还包含一幅小图片
2.最后一行包含每列C：CM

的SUM公式

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

我有一个代码可以完成部分工作（创建具有唯一值的新工作表），但仍在努力解决下一个问题：
1.不复制所有标题（现在仅复制4中的第一行）
2.不保留/复制具有SUM公式的最后一行
3.如果唯一值如：“ aaaaa和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

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

1 个答案: