Question

我不熟悉VBA作为一种语言，我在排序大型电子表格时遇到了问题。该表大约有400,000行乘8列。相关数据从第5行开始。在C列中，我更改了日期的格式并将其向下舍入以给出表示日期的单个整数。

目标是找到数据变化的日期，并将当天的所有数据剪切并粘贴到单独的标签中。我编写的代码在前2天成功执行了此操作，但第3次迭代以及之后的代码将无法正常工作。我使用了颜色代码（蓝色）来表示每一天的最后一行，我正在使用这种颜色变化作为我的循环条件。第3个循环忽略第1个颜色变化，而是剪切和粘贴2天的数据，第4个循环移动3天。

是否有更有效的方法将每天的数据移至新标签？每天代表28800行乘6列。应该注意的是，在此之前运行另外的宏以便简单地组织原始数据。代码中给我提出问题的部分是“按日期排序数据”注释后面的循环。

任何帮助将不胜感激！提前致谢。附件是我的代码和数据样本

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

无需迭代列表两次。 GetWorkSheet为您创建新的工作表，如果它们不存在并处理任何错误。

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

Answer 2

我不会通过任何单元格着色并使用RemoveDuplicates()对象的Range方法，如下所示：

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

按日期排序大型Excel电子表格 - 第3次迭代失败

2 个答案: