Попробуй это.Мне не нравится добавлять лист ошибки, так как он будет добавлять лист при возникновении ошибки.Поэтому следующий код сканирует все листы и добавляет их в массив.В цикле, после нахождения даты, проверяется, существует ли уже имя листа.Имейте в виду, что код будет добавлять данные при каждом запуске кода (поэтому будут дублироваться данные).Также будут собраны данные за разные годы, но в один и тот же день / месяц без ссылки на год.
Если вы хотите сохранить свой код, обратите внимание на:
1) Exit Subне разрешает выполнение остальной части вашего кода.
2) For Each WS In Worksheets имеет неправильный синтаксис
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