然后为每个创建的工作表 1.按列D升序排序 2.按第4栏分组（个人电子邮件）小计第7栏（数量）
然后显示＆＃34;完成！＆＃34;消息框
代码在下面，但我无法通过＆＃34;人员电子邮件的第一个名字来完成＃34;感谢帮助！
链接查看所需结果 - desired result
链接以查看起点 - starting point
Sub TransferReport()
Dim WS As Worksheet
Dim LastRow As Long
'Check each date
For Each DateEnd In Sheet1.Columns(3).Cells
If DateEnd.Value = "" Then Exit Sub 'Stop program if no date
If IsDate(DateEnd.Value) Then
shtName = Format(DateEnd.Value, "mm.dd") 'Change date to valid tab name
On Error GoTo errorhandler 'if no Date Sheet, go to errorhandler to create new tab
If Worksheets(shtName).Range("A2").Value = "" Then
DateEnd.EntireRow.Copy Destination:=Worksheets(shtName).Range("A2")
Worksheets(shtName).Range("A1:M1").Columns.AutoFit
Else
DateEnd.EntireRow.Copy Destination:=Worksheets(shtName).Range("A1").End(xlDown).Offset(1)
End If
End If
Next
Exit Sub
errorhandler:
Sheets.Add After:=Sheets(Sheets.Count) 'Create new tab
ActiveSheet.Name = shtName 'Name tab with date
Sheet1.Rows(1).EntireRow.Copy Destination:=ActiveSheet.Rows(1) 'Copy heading to new tab
Resume
'SortAllSheets()
'Ascending sort on A:M using column D, all sheets in workbook
For Each WS In Worksheets
WS.Columns("A:M").Sort Key1:=WS.Columns("D"), Header:=xlYes, Order1:=xlAscending
Next WS
'SubTotals()
For Each WS In Worksheets
With wsDst
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A1:M" & LastRow).Subtotal GroupBy:=4, Function:=xlSum, TotalList:=Array(7), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End With
Next
添加的图像显示在图片和所需结果之前： 在图片之前 - before data
在图片之后 - desired result
答案 0 :(得分：1)
试试这个。我不想在错误上添加表单，因为每当出现错误时它都会添加表单。因此，以下代码扫描所有工作表，并将它们添加到数组中。在循环中，找到日期后，检查工作表名称是否已存在。请记住，每次运行代码时代码都会添加数据（因此会有重复的数据）。此外，不同年份但同一天/月的数据将聚集在一起，而不提及年份。
如果您想保留代码，请注意：
1）Exit Sub不允许执行其余代码。
2）For Each WS In Worksheets有错误的sintax
3）Worksheets(shtName).Range("A1:M1").Columns.AutoFit仅考虑自动调整的第一行
4）如果中间有一个没有日期的单元格，则If DateEnd.Value = "" Then 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