按列值将数据拆分为不同的工作表

假设我有一个工作表，A 列中有多个不同的值。有没有办法创建一个宏，将列条目为 0 的所有行放入一个单独的工作表中，所有行的条目 1 都放在另一个工作表中，依此类推？我的第一直觉是创造一些东西：

1) 按相关列排序

2) 使用 IF 语句检查前一个单元格和下一个单元格之间的差异为 0 的第一个位置

3) 创建一个新工作表，复制第一个差异 0 之前的所有行，包括计算中产生差异 0 的第一个单元格

4) 选择新工作表并将数据块粘贴到

5) 继续此过程，直到与正在检查的列不同的计数器列中的空白单元格产生空白值（这是因为正在排序的列确实有空白值）

有更好的方法来解决这个问题吗？如果没有，在构建上述内容时提供任何帮助将不胜感激。随着我的进展，我将尝试用新代码更新这篇文章。

更新：我认为这是朝着正确方向迈出的一步，如果有人能提供建议那就太好了。

Dim lastrow As Long
Dim myRange As Long


lastrow = Cells(Rows.Count, "A").End(xlUp).Row
myRange = Range("G1:G" & lastrow)

For i = 1 To myRange.Rows.Count
    If myRange(i, i+1) <> 0 then
        Range("1:i").Copy
    Sheets.Add After:=Sheet(3)
    Sheet(3).Paste
    ElseIf myRange(i , i+1) = 0
    End If
Next i

我认为这种设计将带您到达目的地...考虑一个如下所示的工作簿：

下面的脚本将在第 2 列中找到一个空白单元格（可在代码中自定义），然后根据您的规范对数据块进行操作。内置了一些健全性检查，包括唯一组的计数（您真的想要超过 25 个结果表吗？当然，该数字可以在代码中自定义），并且您是否期望对超过 10,000 行进行操作？ （行检查也是可定制的。）

Option Explicit
Sub SplitDataIntoSheets()

Dim SafetyCheckUniques As Long
SafetyCheckUniques = 25 '<~ more than this number of output sheets? might be a mistake...
Dim SafetyCheckBlank As Long
SafetyCheckBlank = 10000 '<~ more than this number of rows? might be a mistake...
Dim ErrorCheck As Long

Dim Data As Worksheet, Target As Worksheet
Dim LastCol As Long, BlankCol As Long, _
    GroupCol As Long, StopRow As Long, _
    HeaderRow As Long, Index As Long
Dim GroupRange As Range, DataBlock As Range, _
    Cell As Range
Dim GroupHeaderName As String
Dim Uniques As New Collection

'set references up-front
Set Data = ThisWorkbook.Worksheets("Data")  '<~ assign the data-housing sheet
GroupHeaderName = "ID"                      '<~ the name of the column with our groups
BlankCol = 2                                '<~ the column where our blank "stop" row is
GroupCol = 1                                '<~ the column containing the groups
HeaderRow = 1                               '<~ the row that has our headers
LastCol = FindLastCol(Data)
StopRow = FindFirstBlankInCol(BlankCol, HeaderRow, Data)

'sanity check: if the first blank is more than our safety number,
'              we might have entered the wrong BlankCol
ErrorCheck = 0
If StopRow > SafetyCheckBlank Then
    ErrorCheck = MsgBox("Dang! The first blank row in column " & _
                        BlankCol & " is more than " & SafetyCheckBlank & _
                        " rows down... Are you sure you want to run this" & _
                        " script?", vbYesNo, "That's a lot of rows!")
    If ErrorCheck = vbNo Then Exit Sub
End If

'identify how many groups we have
With Data
    Set GroupRange = .Range(.Cells(HeaderRow, GroupCol), .Cells(StopRow, GroupCol))
    GroupRange.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    For Each Cell In GroupRange.SpecialCells(xlCellTypeVisible)
        If Cell.Value <> GroupHeaderName Then
            Uniques.Add (Cell.Value)
        End If
    Next Cell
End With
Call ClearAllFilters(Data)

'sanity check: if there are more than 25 unique groups, do we really want
'              more than 25 sheets? prompt user...
ErrorCheck = 0
If Uniques.Count > SafetyCheckUniques Then
    ErrorCheck = MsgBox("Whoa! You've got " & Uniques.Count & " groups in column " & _
                        GroupCol & ", which is more than " & SafetyCheckUniques & _
                        " (which is a lot of resultant sheets). Are you sure you" & _
                        " want to run this script?", vbYesNo, "That's a lot of sheets!")
    If ErrorCheck = vbNo Then Exit Sub
End If

'loop through the unique collection, filtering the data block
'on each unique and copying the results to a new sheet
With Data
    Set DataBlock = .Range(.Cells(HeaderRow, GroupCol), .Cells(StopRow, LastCol))
End With
Application.DisplayAlerts = False
For Index = 1 To Uniques.Count
    Call ClearAllFilters(Data)
    'make sure the sheet doesn't exist already... delete the sheet if it's found
    If DoesSheetExist(Uniques(Index)) Then
        ThisWorkbook.Worksheets(CStr(Uniques(Index))).Delete
    End If
    'now build the sheet and copy in the data
    Set Target = ThisWorkbook.Worksheets.Add
    Target.Name = Uniques(Index)
    DataBlock.AutoFilter Field:=GroupCol, Criteria1:=Uniques(Index)
    DataBlock.SpecialCells(xlCellTypeVisible).Copy Destination:=Target.Cells(1, 1)
Next Index
Application.DisplayAlerts = True
Call ClearAllFilters(Data)

End Sub


'INPUT: a worksheet name (string)
'RETURN: true or false depending on whether or not the sheet is found in this workbook
'SPECIAL CASE: none
Public Function DoesSheetExist(dseSheetName As String) As Boolean
    Dim obj As Object
    On Error Resume Next
    'if there is an error, sheet doesn't exist
    Set obj = ThisWorkbook.Worksheets(dseSheetName)
    If Err = 0 Then
        DoesSheetExist = True
    Else
        DoesSheetExist = False
    End If
    On Error GoTo 0
End Function

'INPUT: a column number (long) to examine, the header row we should start in (long)
'       and the worksheet that both exist in
'RETURN: the row number of the first blank
'SPECIAL CASE: return 0 if column number is <= zero,
'return 0 if the header row is <= zero,
'return 0 if sheet doesn't exist
Public Function FindFirstBlankInCol(ffbicColNumber As Long, ffbicHeaderRow As Long, _
    ffbicWorksheet As Worksheet) As Long
    If ffbicColNumber <= 0 Or ffbicHeaderRow <= 0 Then
        FindFirstBlankInCol = 0
    End If
    If Not DoesSheetExist(ffbicWorksheet.Name) Then
        FindFirstBlankInCol = 0
    End If
    'use xl down, will land on the last row before the blank
    With ffbicWorksheet
        FindFirstBlankInCol = .Cells(ffbicHeaderRow, ffbicColNumber).End(xlDown).Row
    End With
End Function

'INPUT: a worksheet on which to identify the last column
'RETURN: the column (as a long) of the last occupied cell on the sheet
'SPECIAL CASE: return 1 if the sheet is empty
Public Function FindLastCol(flcSheet As Worksheet) As Long
    If Application.WorksheetFunction.CountA(flcSheet.Cells) <> 0 Then
        FindLastCol = flcSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    Else
        FindLastCol = 1
    End If
End Function

'INPUT: target worksheet on which to clear filters safely
'TASK: clear all filters
Sub ClearAllFilters(cafSheet As Worksheet)
    With cafSheet
        .AutoFilterMode = False
        If .FilterMode = True Then
            .ShowAllData
        End If
    End With
End Sub