按date对大型Excel电子表格进行sorting – 在第3次迭代中失败
我是新来的VBA作为一种语言，我有sorting大电子表格的问题。 这张纸大约是40万行×8列。 相关数据从第5行开始。在C列中，我更改了date的格式，并将其舍入为一个表示当天的整数。
我们的目标是找出数据在哪里变化，并将当天的所有数据剪切并粘贴到单独的选项卡中。 我写的代码在前两天成功执行了这个操作，但是第三次和以后的代码不能正常工作。 我已经使用颜色代码（蓝色）来表示每天的最后一行，而且我正在使用这种颜色更改作为我的循环条件。 第3个循环忽略第1个颜色变化，而是剪切粘贴2天的数据，第4个循环移动3天。
是否有更有效的方法将每一天的数据移动到一个新的标签？ 每天代表28800行×6列。 应该注意的是，在这之前运行一个额外的macros，以便简单地组织原始数据。 给我的问题的代码部分是按照“按datesorting数据”的评论循环。
任何帮助将不胜感激！ 提前致谢。 附上是我的代码和数据的一个样本
Sub HOBO_Split_v2() 'Before this code can be run, you must run "Hobo_Organize" 1 time. Press 'Ctrl + Shift + O' to do this 'The purpose of this code is to separate the hobo data by day. Weekends and evenings will be removed. 'This will create smaller data sets, which allows for easier data manipulation Application.ScreenUpdating = False 'Find the last row Lastrow = Range("C" & Rows.Count).End(xlUp).Row 'Set the known parameters Dim days As Range Set days = Worksheets("Full Data Set").Range("C5:C" & Lastrow) Dim daychanges As String daychanges = 0 'Maximum of 3 weeks of data, 21 different sheets Dim sheetnum(1 To 21) As Integer For i = 1 To 21 sheetnum(i) = i Next i 'Loop through the day index (Col C), counting the number of day changes For Each cell In days If cell.Value <> cell.Offset(1).Value Then cell.Interior.ColorIndex = 37 daychanges = daychanges + 1 End If Next cell 'Add new sheets for each day and rename the sheets Sheets.Add after:=ActiveSheet ActiveSheet.Name = "Day 1" For i = 2 To daychanges Sheets.Add Before:=ActiveSheet ActiveSheet.Name = "Day " & sheetnum(i) Next i Sheets("Full Data Set").Select 'Sort the data by date For Each cell In days If cell.Interior.ColorIndex = 37 Then cell.Select Range(Selection, Selection.End(xlUp)).Select Range(Selection, Selection.End(xlToRight)).Select Selection.Cut Worksheets(Worksheets.Count).Select ActiveSheet.Range("B2").Select ActiveSheet.Paste Application.CutCopyMode = False ActiveSheet.Move Before:=Sheets("Full Data Set") Sheets("Full Data Set").Select Range("C4").Select Selection.End(xlDown).Select Range(Selection, Selection.End(xlDown)).Select Set days = Selection End If Next cell Application.ScreenUpdating = True End Sub 数据的例子
我不通过任何单元格着色，并使用Range对象的RemoveDuplicates()方法，如下所示：
Option Explicit Sub HOBO_Split_v2() Dim datesRng As Range, dataRng As Range, cell As Range Dim iDay As Long Application.ScreenUpdating = False With ThisWorkbook.Worksheets("Full Data Set") Set datesRng = .Range("C5", .Cells(.Rows.Count, 3).End(xlUp)) '<--| set dates range Set dataRng = datesRng.offset(-1).Resize(datesRng.Rows.Count + 1, 6) '<--| set data range as dates one extended to next 5 columns With datesRng.offset(, .UsedRange.Columns.Count) '<--| use a helper column out of current used range .value = datesRng.value '<--| copy dates value in helper column .RemoveDuplicates Columns:=Array(1) '<--| remove duplicates and have only unique values in helper column For Each cell In .Cells.SpecialCells(xlCellTypeConstants, xlNumbers) '<--| iterate through remaining (unique) day values in helper column iDay = iDay + 1 '<--| update "current day" counter dataRng.AutoFilter Field:=1, Criteria1:=Format(cell, "#.00") '<--| filter data by "current day", format the criteria as the actual column C cells format dataRng.offset(1).Resize(dataRng.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Destination:=SetWorkSheet(ThisWorkbook, "Day " & iDay).Range("B2") '<--| copy filtered data and paste the into "current day" corresponding sheet Next cell .Parent.AutoFilterMode = False '<--| remove autofilter .Clear '<--| clear helper column End With End With Application.ScreenUpdating = True End Sub Function SetWorkSheet(wb As Workbook, SheetName As String) As Worksheet On Error Resume Next Set SetWorkSheet = wb.Worksheets(SheetName) On Error GoTo 0 If SetWorkSheet Is Nothing Then Set SetWorkSheet = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count)) SetWorkSheet.Name = SheetName Else SetWorkSheet.UsedRange.Clear '<--| clear preceeding values in already existent sheet End If End Function
没有必要遍历列表两次。 GetWorkSheet不存在并处理任何错误， GetWorkSheet将为您创build新的工作表。
Sub HOBO_Split_v2() Application.ScreenUpdating = False Dim cell As Range, days As Range Dim lFirstRow As Long, Lastrow As Long Dim SheetName As String Dim ws As Worksheet With Sheets("Full Data Set") Lastrow = Range("C" & Rows.Count).End(xlUp).Row Set days = .Range("C5:C" & Lastrow) For Each cell In days If c.Text <> SheetName Or c.Row = Lastrow Then If lFirstRow > 0 Then Set ws = getWorkSheet(SheetName) .Range("A" & lFirstRow, "A" & cell.Row).EntireRow.Copy ws.Range("A1") End If SheetName = c.Text lFirstRow = i End If Next End With Application.ScreenUpdating = True End Sub Function getWorkSheet(SheetName As String) As Worksheet Dim ws As Worksheet On Error Resume Next Set ws = Worksheets(SheetName) If ws Is Nothing Then Set ws = Worksheets.Add(after:=ActiveSheet) ws.Name = SheetName End If On Error GoTo 0 Set getWorkSheet = ws End Function