thank you for the help- novice, but learning I have a worksheet need to do the following: 1. check each date 2. move rows where data values are the same to a new sheet 3. rename that tab the mm.dd of the value
then for each sheet created 1. sort by column D Ascending 2. group by column 4 (person email) subtotal column 7 (quantity)
at then end display a "Complete!" message box
code is below, but I cannot get it to complete through the first name of "person email" Help is appreciated!
Link to see Desired Result - desired result
Link to see starting point- 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
Images are added showing before picture and desired results: BEFORE PICTURE - before data
after picture- desired result
Try this. I don't like to add a sheet onerror, since it will add a sheet whenever there is an error. So the following code scan for all sheets, and add them to an array. In the loop, after finding a date, checks if sheet name already exist. Keep in mind that code will add data each time you run the code (so there will be duplicated data). Also data from different years but same day/month will be gather together, with no reference to year.
If you want to keep your code, pay attention to:
1)Exit Sub does not allow execution of the rest of your code.
2)For Each WS In Worksheets has wrong sintax
3) Worksheets(shtName).Range("A1:M1").Columns.AutoFit only take into account first row for Autofit
4) If DateEnd.Value = "" Then Exit Sub will exit code if there is a cell in between with no date
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
EDIT
Seems that you want to make a report. I usually feel uncomfortable with grouping, and like to explicitly state what I want. Of course this is a personal preference. But if it is also your case, try the code below. Each time you run the macro, report sheets will be deleted and new ones created. Also there is no modification in main sheet ("Sheet1"). This way you have more control on the output.
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