试试这个。我不喜欢在错误时添加工作表，因为它会在出现错误时添加工作表。因此，以下代码扫描所有工作表，并将它们添加到数组中。在循环中，找到日期后，检查工作表名称是否已存在。请记住，每次运行代码时代码都会添加数据（因此会有重复的数据）。不同年份但同一天/月的数据也将收集在一起，不参考年份。
如果你想保留你的代码，请注意：
1)Exit Sub 不允许执行您的其余代码。
2)For Each WS In Worksheets有错误的sintax
3) Worksheets(shtName).Range("A1:M1").Columns.AutoFit 只考虑 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