首页 文章

将具有唯一值的所有行复制到包含 Headers 行的新工作表

提问于
浏览 次
2

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

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

我有一个代码来完成部分工作（创建具有唯一值的新工作表），但仍然在努力解决下一个问题：
1.不复制所有 Headers （现在只复制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

非常感谢任何帮助！

excel vba

1 回答

  • 0

    我设法修复了我的代码并获得了正确的结果（在命名电子表格时仍然存在一些问题，因为有些名称相当长而且excel不会将它们命名为选项卡），但无论如何这里是代码正在做的事情：
    1.根据主工作表的特定范围（A5：..）中的唯一值创建新电子表格并复制相应的行
    2.根据唯一值重命名新电子表格
    3.将所有 Headers 的行（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
    回复于

相关问题