vba将数据移动到新选项卡、排序和小计excel

谢谢你的帮助-新手，但学习 我有一个工作表，需要执行以下操作： 1.检查每个日期 2.将数据值相同的行移动到新图纸 3.将该选项卡重命名为该值的mm.dd

然后为每个创建的图纸 1.按D列升序排序 2.按第4列分组（个人电子邮件）第7列小计（数量）

最后显示一个“完成！”消息框

代码如下，但我无法通过“个人电子邮件”的名字来完成。非常感谢您的帮助
链接以查看所需结果- 链接以查看起点-

在图片和所需结果之前添加图像： 图片前-

---

在图片之后-

试试这个。我不喜欢在错误中添加工作表，因为每当出现错误时，它都会添加工作表。下面的代码扫描所有工作表，并将它们添加到数组中。在循环中，找到日期后，检查图纸名称是否已存在。请记住，每次运行代码时，代码都会添加数据（因此会有重复的数据）。此外，将收集不同年份但同一天/月的数据，不参考年份

如果要保留代码，请注意：

1）

Exit Sub

不允许执行其余代码

2） 工作表中每个WS的

的sintax错误

3） 
工作表（shtName）.Range（“A1:M1”）.Columns.AutoFit
仅考虑自动拟合的第一行

4） 
如果DateEnd.Value=”“则Exit Sub
将在中间有一个没有日期的单元格时退出代码

Sub TransferReport()
Dim WS As Worksheet
Dim MainSheet As Worksheet
Dim LastRow As Long
Dim DateEnd As Range
Dim NextLastRow As Long
Dim i As Long
Dim ArraySheets() As String
Dim shtName As String


'Store sheet names in array
ReDim ArraySheets(1 To Sheets.Count)
For i = 1 To ThisWorkbook.Sheets.Count
        ArraySheets(i) = ThisWorkbook.Sheets(i).Name
Next

'Check each date
Set MainSheet = ThisWorkbook.Worksheets("Sheet1")
LastRow = MainSheet.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
    If IsDate(MainSheet.Cells(i, 3).Value) Then
        shtName = Format(MainSheet.Cells(i, 3).Value, "mm.dd")
        If Not IsInArray(shtName, ArraySheets) Then
            With ThisWorkbook
                Set WS = .Sheets.Add(After:=.Sheets(.Sheets.Count)) 'Create new tab
                WS.Name = shtName 'Name tab with date
                MainSheet.Rows(1).EntireRow.Copy Destination:=WS.Rows(1) 'Copy heading to new tab
                ArraySheets(UBound(ArraySheets)) = shtName
                ReDim Preserve ArraySheets(1 To UBound(ArraySheets) + 1) As String 'add new sheet name to array
            End With
        End If

        NextLastRow = Worksheets(shtName).Cells(Rows.Count, 1).End(xlUp).Row + 1
        MainSheet.Rows(i).EntireRow.Copy Destination:=Worksheets(shtName).Cells(NextLastRow, 1)
        Worksheets(shtName).Columns("A:M").Columns.AutoFit
    End If
Next

'   'Ascending sort on A:M using column D, all sheets in workbook
   For Each WS In ActiveWorkbook.Worksheets
      WS.Columns("A:M").Sort Key1:=WS.Columns("D"), Header:=xlYes, Order1:=xlAscending
      LastRow = WS.Range("A" & Rows.Count).End(xlUp).Row
      WS.Range("A1:M" & LastRow).Subtotal GroupBy:=4, Function:=xlSum, TotalList:=Array(7), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
   Next WS

End Sub

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
    IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function

编辑

看来你想做个报告。我通常对分组感到不舒服，并且喜欢明确地说出我想要什么。当然，这是个人偏好。但如果这也是您的情况，请尝试下面的代码。每次运行宏时，都会删除报告表并创建新的报告表。主工作表中也没有修改（
“Sheet1”
）。这样，您可以更好地控制输出

Dim WS As Worksheet
Dim MainSheet As Worksheet
Dim LastRow As Long
Dim DateEnd As Range
Dim NextLastRow As Long
Dim i As Long
Dim ArraySheets() As String
Dim shtName As String
Dim TheRow As Long
Dim TheSum As Variant
Dim WSName As Variant, TheCustomerMail As String


'Store Main sheet name in array
ReDim ArraySheets(1 To 1)
ArraySheets(1) = ActiveWorkbook.Worksheets("Sheet1").Name

'Delete all previous sheets, except main one ("Sheet1")
Application.DisplayAlerts = False
For i = ThisWorkbook.Sheets.Count To 1 Step -1
    If Sheets(i).Name <> "Sheet1" Then
        ThisWorkbook.Sheets(i).Delete
    End If
Next
Application.DisplayAlerts = True

'Check each date
Set MainSheet = ActiveWorkbook.Worksheets("Sheet1")
LastRow = MainSheet.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
    If IsDate(MainSheet.Cells(i, 3).Value) Then
        shtName = Format(MainSheet.Cells(i, 3).Value, "mm.dd")
        If Not IsInArray(shtName, ArraySheets) Then
            With ThisWorkbook
                Set WS = .Sheets.Add(After:=.Sheets(.Sheets.Count)) 'Create new tab
                WS.Name = shtName 'Name tab with date
                MainSheet.Rows(1).EntireRow.Copy Destination:=WS.Rows(1) 'Copy heading to new tab
                ReDim Preserve ArraySheets(1 To UBound(ArraySheets) + 1) As String
                ArraySheets(UBound(ArraySheets)) = shtName
            End With
        End If

        NextLastRow = Worksheets(shtName).Cells(Rows.Count, 1).End(xlUp).Row + 1
        MainSheet.Rows(i).EntireRow.Copy Destination:=Worksheets(shtName).Cells(NextLastRow, 1)
        Worksheets(shtName).Columns("A:M").Columns.AutoFit
    End If
Next

'Ascending sort on A:M using column D, all sheets in workbook
For Each WSName In ArraySheets
    TheCustomerMail = "" 'Starting name
    TheSum = ""

    If WSName <> "Sheet1" Then 'Only sort "new" sheets, not main one
        Worksheets(WSName).Columns("A:M").Sort Key1:=Worksheets(WSName).Columns("D"), Header:=xlYes, Order1:=xlAscending
        LastRow = Worksheets(WSName).Range("A" & Rows.Count).End(xlUp).Row
        TheRow = LastRow + 1
        For i = LastRow To 1 Step -1
            If i = 1 Then
                Worksheets(WSName).Cells(TheRow, 5) = TheSum
            Else
                If Worksheets(WSName).Cells(i, 4).Value <> TheCustomerMail Then
                    Worksheets(WSName).Cells(TheRow, 5) = TheSum
                    Worksheets(WSName).Rows(i + 1).Insert shift:=xlShiftDown
                    Worksheets(WSName).Rows(i + 1).Insert shift:=xlShiftDown
                    TheRow = i + 1
                    TheSum = Worksheets(WSName).Cells(i, 5).Value
                    TheCustomerMail = Worksheets(WSName).Cells(i, 4).Value
                    'Worksheets(WSName).Rows(i + 1).Columns("A:M").Interior.ColorIndex = 16
                    'Worksheets(WSName).Rows(i + 1).Columns("A:M").Font.ColorIndex = 2
                    Worksheets(WSName).Rows(i + 1).Columns("A:M").Font.Bold = True
                    Worksheets(WSName).Cells(i + 1, 4) = "Total of " & TheCustomerMail & ":"
                    Worksheets(WSName).Columns("D").Columns.AutoFit
                Else
                    TheSum = TheSum + Worksheets(WSName).Cells(i, 5).Value
                End If
            End If
        Next
    End If
Next

End Sub

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
    IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function

Dim WS As工作表
将主工作表调整为工作表
最后一排一样长
Dim DATEND As范围
暗淡的下一个星星和长的一样
我想我会坚持多久
Dim ArraySheets（）作为字符串
作为字符串的Dim shtName
把它调暗，直到它变长
变型模糊推理
Dim WSName作为变量，CustomerMail作为字符串
'将主工作表名称存储在数组中
ReDim阵列表（1对1）
数组表（1）=活动工作簿。工作表（“表1”）。名称
'删除所有以前的工作表，主工作表除外（“工作表1”）
Application.DisplayAlerts=False
对于i=ThisWorkbook.Sheets.Count，计数为1步骤-1
如果是第（i）页，则命名为“Sheet1”
此工作簿。工作表（i）。删除
如果结束
下一个
Application.DisplayAlerts=True
“检查每个日期
设置MainSheet=ActiveWorkbook.Worksheets（“Sheet1”）
LastRow=MainSheet.Cells（Rows.Count，1）.End（xlUp）.Row
对于i=2到最后一行
如果是IsDate（主表单元格（i，3）.值），则
shtName=格式（MainSheet.Cells（i，3）.值，“mm.dd”）
如果不是IsInArray（shtName，ArraySheets），那么
使用此工作簿
设置WS=.Sheets.Add（之后：=.Sheets（.Sheets.Count））'创建新选项卡
WS.Name=shtName的带有日期的名称选项卡
MainSheet.Rows（1）.EntireRow.Copy目标：=WS.Rows（1）'将标题复制到新选项卡
ReDim将数组表（1到UBound（数组表）+1）保留为字符串
阵列表（UBound（阵列表））=shtName
以
如果结束
NextLastRow=工作表（shtName）.单元格（Rows.Count，1）.结束（xlUp）.行+1
MainSheet.Rows（i）.EntireRow.Copy Destination:=工作表（shtName）.Cells（NextLastRow，1）
工作表（shtName）.Columns（“A:M”）.Columns.AutoFit
如果结束
下一个
'使用工作簿中的所有工作表的D列对A:M进行升序排序
对于阵列表中的每个WSName
客户邮件=“开始名称”
TheSum=“”
如果WSName为“Sheet1”，则“仅对“新”工作表排序，而不是对主工作表排序”
工作表（WSName）.Columns（“A:M”）.Sort Key1:=工作表（WSName）.Columns（“D”），Header:=xlYes，Order1:=xl
LastRow=工作表（WSName）.Range（“A”&Rows.Count）.End（xlUp）.Row
TheRow=LastRow+1
对于i=最后一行到1步骤-1
如果i=1，那么
工作表（WSName）.Cells（TheRow，5）=TheSum
其他的
如果工作表（WSName）.Cells（i，4）.为客户邮件赋值，则
工作表（WSName）.Cells（TheRow，5）=TheSum
工作表（WSName）.行（i+1）.插入移位：=xlShiftDown
工作表（WSName）.行（i+1）.插入移位：=xlShiftDown
TheRow=i+1
TheSum=工作表（WSName）.Cells（i，5）.Value
客户邮件=工作表（WSName）.Cells（i，4）.Value
'工作表（WSName）.行（i+1）.列（“A:M”）.Interior.ColorIndex=16
'工作表（WSName）.行（i+1）.列（“A:M”）.Font.ColorIndex=2
工作表（WSName）.行（i+1）.列（“A:M”）.Font.Bold=True
工作表（WSName）.Cells（i+1,4）=“总计”&客户邮件&“
工作表（WSName）.Columns（“D”）.Columns.AutoFit
其他的
TheSum=TheSum+工作表（WSName）.Cells（i，5）.Value
如果结束
如果结束
下一个
如果结束
下一个
端接头
函数IsInArray（StringToBeford作为字符串，arr作为变量）作为布尔值
IsInArray=（UBound（过滤器（arr，stringToBeFound））>-1）
端函数
每次运行代码时，如果Sheet1 C列中的数据是日期，则创建工作表并复制数据，或者如果工作表已存在，则从Sheet1复制行。如果多次运行代码，将复制重复的数据。排序和小计不起作用，至少部分原因是for-each循环错误。但根本不清楚你想要实现什么。如果你能添加一些细节来了解你的目标，这将是有益的。也考虑
Dim WS As Worksheet
Dim MainSheet As Worksheet
Dim LastRow As Long
Dim DateEnd As Range
Dim NextLastRow As Long
Dim i As Long
Dim ArraySheets() As String
Dim shtName As String
Dim TheRow As Long
Dim TheSum As Variant
Dim WSName As Variant, TheCustomerMail As String


'Store Main sheet name in array
ReDim ArraySheets(1 To 1)
ArraySheets(1) = ActiveWorkbook.Worksheets("Sheet1").Name

'Delete all previous sheets, except main one ("Sheet1")
Application.DisplayAlerts = False
For i = ThisWorkbook.Sheets.Count To 1 Step -1
    If Sheets(i).Name <> "Sheet1" Then
        ThisWorkbook.Sheets(i).Delete
    End If
Next
Application.DisplayAlerts = True

'Check each date
Set MainSheet = ActiveWorkbook.Worksheets("Sheet1")
LastRow = MainSheet.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
    If IsDate(MainSheet.Cells(i, 3).Value) Then
        shtName = Format(MainSheet.Cells(i, 3).Value, "mm.dd")
        If Not IsInArray(shtName, ArraySheets) Then
            With ThisWorkbook
                Set WS = .Sheets.Add(After:=.Sheets(.Sheets.Count)) 'Create new tab
                WS.Name = shtName 'Name tab with date
                MainSheet.Rows(1).EntireRow.Copy Destination:=WS.Rows(1) 'Copy heading to new tab
                ReDim Preserve ArraySheets(1 To UBound(ArraySheets) + 1) As String
                ArraySheets(UBound(ArraySheets)) = shtName
            End With
        End If

        NextLastRow = Worksheets(shtName).Cells(Rows.Count, 1).End(xlUp).Row + 1
        MainSheet.Rows(i).EntireRow.Copy Destination:=Worksheets(shtName).Cells(NextLastRow, 1)
        Worksheets(shtName).Columns("A:M").Columns.AutoFit
    End If
Next

'Ascending sort on A:M using column D, all sheets in workbook
For Each WSName In ArraySheets
    TheCustomerMail = "" 'Starting name
    TheSum = ""

    If WSName <> "Sheet1" Then 'Only sort "new" sheets, not main one
        Worksheets(WSName).Columns("A:M").Sort Key1:=Worksheets(WSName).Columns("D"), Header:=xlYes, Order1:=xlAscending
        LastRow = Worksheets(WSName).Range("A" & Rows.Count).End(xlUp).Row
        TheRow = LastRow + 1
        For i = LastRow To 1 Step -1
            If i = 1 Then
                Worksheets(WSName).Cells(TheRow, 5) = TheSum
            Else
                If Worksheets(WSName).Cells(i, 4).Value <> TheCustomerMail Then
                    Worksheets(WSName).Cells(TheRow, 5) = TheSum
                    Worksheets(WSName).Rows(i + 1).Insert shift:=xlShiftDown
                    Worksheets(WSName).Rows(i + 1).Insert shift:=xlShiftDown
                    TheRow = i + 1
                    TheSum = Worksheets(WSName).Cells(i, 5).Value
                    TheCustomerMail = Worksheets(WSName).Cells(i, 4).Value
                    'Worksheets(WSName).Rows(i + 1).Columns("A:M").Interior.ColorIndex = 16
                    'Worksheets(WSName).Rows(i + 1).Columns("A:M").Font.ColorIndex = 2
                    Worksheets(WSName).Rows(i + 1).Columns("A:M").Font.Bold = True
                    Worksheets(WSName).Cells(i + 1, 4) = "Total of " & TheCustomerMail & ":"
                    Worksheets(WSName).Columns("D").Columns.AutoFit
                Else
                    TheSum = TheSum + Worksheets(WSName).Cells(i, 5).Value
                End If
            End If
        Next
    End If
Next

End Sub

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
    IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function