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

Question

假设我在 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

Answer 1

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

下面的脚本将在第 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

Answer 2

我要发布的代码当然不完美，但它会让你更接近你的目标。

首先，我们需要知道如何查看工作表是否存在，如果不存在，如何创建它。请注意，布尔类型被隐式初始化为False。

Private Function isWorksheet(wsName As String) As Boolean
    Dim ws As Worksheet
    ' loop through each worksheet in this workbook
    For Each ws In ThisWorkbook.Worksheets
        If wsName = ws.name Then
            ' we found it! return true and exit the loop
            isWorksheet = True
            Exit For
        End If
    Next ws
End Function

Private Function insertNewWorksheet(wsName As String) As Worksheet
' returns newly created worksheet
    Dim ws As Worksheet
    ' add worksheet after all other worksheets; simultaneously setting ws = the added worksheet
    Set ws = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Worksheets.Count))
    ' rename it
    ws.name = wsName
    ' return
    Set insertNewWorksheet = ws
End Function

接下来，我们需要能够找到任何给定工作表的最后一行，因此我将使用您的代码 sn-p 并将其转换为接受工作表对象的函数。

Private Function lastrow(ws As Worksheet) As Long
    lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
End Function

最后，我们将把它们整合到我们的主程序中。这将遍历myRange（G 列）中的每个单元格，创建目标工作表并将值发送到 A 列 (1) 中的最后一个可用行。

Sub processStuff()
Dim myRange As Range
Dim c As Range 'cell
Dim destWs As Worksheet
Dim srcWs As Worksheet

' use currently active sheet as source
Set srcWs = ThisWorkbook.ActiveSheet
' set my range
Set myRange = srcWs.Range("G1:G" & lastrow(srcWs))

For Each c In myRange
    Dim destWsName As String
    destWsName = "Dest_" & c.Value
    If isWorksheet(destWsName) Then
        'use that worksheet
        Set destWs = ThisWorkbook.Sheets(destWsName)
    Else
        'create worksheet
        Set destWs = insertNewWorksheet(destWsName)
    End If
    ' sets destination cell's value
    'destWs.Cells(lastrow(destWs) + 1, 1).Value = c.Value
    ' OP asked for entire row. Oops.
    destWs.Cells(lastrow(destWs) + 1), 1).EntireRow.Value = c.EntireRow.Value
Next c

End Sub

Answer 3

是的。这里有一些伪代码可以帮助您入门。

For i = 1 To myRange.Rows.Count
    If myRange(i, 1) = 0 then
        'Omitted code to move to other sheet'
    ElseIf myRange(i , 1) = 1
        'And so on'
    End If
Next i

随时发布您的尝试，我们将一路为您提供帮助。如果你宁愿只付钱，我很乐意给你报价。 :)

如果您需要更多基础知识，Google 将提供大量 VBA 教程。