Question

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

1）按相关列进行排序

2）使用IF语句来检查前一个小区和下一个小区之间的差异是＆lt;＆gt;的第一个位置。 0

3）创建新工作表，复制第一个差异之前的所有行＆lt;＆gt; 0包括计算中的第一个单元，产生差值＆lt;＆gt;。 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

我认为这个设计可以帮助您实现目标......考虑一下这样的工作簿：

114

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

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

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中提供大量教程。

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

3 个答案: