vba 将数据移动到新选项卡、排序和小计 excel
vba to move data to new tab, sort and subtotal excel
谢谢帮助-新手，不过学习中
我有一个工作sheet需要做以下事情：
1.检查每个日期
2. 将数据值相同的行移动到新的 sheet
3. 将该选项卡重命名为值
的 mm.dd
然后为每个 sheet 创建
1.按D列升序排序
2. 按第 4 列（个人电子邮件）小计第 7 列（数量）分组
然后结束时显示一个 "Complete!" 消息框
代码在下面，但我无法通过 "person email" 的名字完成它，感谢帮助！
Link 查看预期结果 - desired result
Link 看起点- 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
试试这个。我不喜欢添加 sheet onerror，因为它会在出现错误时添加 sheet。所以下面的代码扫描所有 sheets，并将它们添加到一个数组中。在循环中，找到日期后，检查 sheet 名称是否已存在。请记住，每次您 运行 代码时，代码都会添加数据（因此会有重复的数据）。来自不同年份但相同 day/month 的数据也将收集在一起，不参考年份。
如果你想保留你的代码，请关注：
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
编辑
看来你要举报了。我通常对分组感到不自在，喜欢明确说明我想要什么。当然这是个人喜好。但如果这也是你的情况，请尝试下面的代码。每次您 运行 宏时，报告 sheet 将被删除并创建新的。 main sheet ("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
谢谢帮助-新手，不过学习中 我有一个工作sheet需要做以下事情： 1.检查每个日期 2. 将数据值相同的行移动到新的 sheet 3. 将该选项卡重命名为值
的 mm.dd然后为每个 sheet 创建 1.按D列升序排序 2. 按第 4 列（个人电子邮件）小计第 7 列（数量）分组
然后结束时显示一个 "Complete!" 消息框
代码在下面，但我无法通过 "person email" 的名字完成它，感谢帮助！
Link 查看预期结果 - desired result
Link 看起点- 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
试试这个。我不喜欢添加 sheet onerror，因为它会在出现错误时添加 sheet。所以下面的代码扫描所有 sheets，并将它们添加到一个数组中。在循环中，找到日期后，检查 sheet 名称是否已存在。请记住，每次您 运行 代码时，代码都会添加数据（因此会有重复的数据）。来自不同年份但相同 day/month 的数据也将收集在一起，不参考年份。
如果你想保留你的代码，请关注：
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
编辑
看来你要举报了。我通常对分组感到不自在，喜欢明确说明我想要什么。当然这是个人喜好。但如果这也是你的情况，请尝试下面的代码。每次您 运行 宏时，报告 sheet 将被删除并创建新的。 main sheet ("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