Sortieren einer großen Excel-Tabelle nach Datum - schlägt bei 3. Iteration fehl

Question

Ich bin neu in VBA als Sprache, und ich habe Probleme beim Sortieren einer großen Tabelle. Das Blatt ist ungefähr 400.000 Reihen mal 8 Spalten. Die relevanten Daten beginnen in Zeile 5. In Spalte C änderte ich das Format des Datums und rundete es auf eine ganze Zahl ab, die den Tag darstellt.

Das Ziel ist es, zu finden, wo die Daten Tage ändern, und alle Daten des Tages ausschneiden und in eine separate Registerkarte einfügen. Der Code, den ich erfolgreich geschrieben habe, tut dies für die ersten 2 Tage, aber die 3. Iteration und darüber hinaus wird nicht richtig funktionieren. Ich habe einen Farbcode (blau) verwendet, um die letzte Zeile für jeden Tag darzustellen, und ich verwende diese Farbänderung als meine Schleifenbedingung. Die 3. Schleife ignoriert die erste Farbänderung und schneidet und fügt stattdessen 2 Tage Daten ein und die 4. Schleife bewegt sich 3 Tage.

Wäre es effizienter, die Daten jedes Tages auf eine neue Registerkarte zu verschieben? Jeder Tag repräsentiert 28800 Zeilen zu 6 Spalten. Es sollte angemerkt werden, dass ein zusätzliches Makro davor ausgeführt wird, um die Rohdaten einfach zu organisieren. Der Teil des Codes, der Probleme verursacht, sind die Schleifen, die dem Kommentar "Sortieren der Daten nach Datum" folgen.

Jede Hilfe würde sehr geschätzt werden! Danke im Voraus. zweimal Beigefügt ist mein Code und eine Probe der Daten

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 

Example of the data

Answer 1

würde ich nicht durch irgendeine Zelle Färbung passieren und als RemoveDuplicates() Methode der Range Objekt verwenden, wie folgt:

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 

Answer 2

Es gibt keine Notwendigkeit, über die Liste zu durchlaufen. erstellen Sie die neuen Arbeitsblätter für Sie, wenn sie nicht vorhanden sind, und gehen Sie mit Fehlern um.

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