通过列值将数据分割成不同的表格 [英] Splitting Data into Different Sheets by Column Values

问题描述

假设我有一个在列A中有多个不同值的工作表。有没有办法创建一个宏，它将所有列列入条目0并将它们放在一个单独的工作表中，所有这些都与另一个工作表中的条目1等等？我的第一本能就是创造出一些东西：

1）按照有问题的列排序

2）使用检查前一个单元格和下一个单元格之间的差异的第一个位置的IF语句是<>

3）创建新工作表，复制所有包括计算中的第一个单元格之前的第一个差值之间的行

4）选择新工作表并粘贴数据块在

5）继续此过程，直到从被检查的列中的计数器列中的空白单元格差异为空值（这是因为正在排序的列具有空白值）

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

更新：我认为这是朝着正确方向迈出的一步，如果有人可以建议这将是伟大的

  Dim lastrow As Long 
 Dim myRange As Long 
 
 
 lastrow =单元格（Rows.Count，A）。End（xlUp）.Row 
 myRange = Range（G1：G& lastrow）
 
对于i = 1到myRange。 Rows.Count 
如果myRange（i，i + 1）<> 0然后
 Range（1：i）。复制
 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'<〜多于此数量的输出单？可能是一个错误... 
 Dim SafetyCheckBlank As Long 
 SafetyCheckBlank = 10000'<〜多于这行数？可能是一个错误... 
 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 
设置数据= ThisWorkbook.Worksheets（Data）'<〜分配数据外壳
 GroupHeaderName =ID'<〜我们组的列名称
 BlankCol = 2'<〜我们的空白停止行的列为
 GroupCol = 1'<〜列包含组
 HeaderRow = 1'<〜有我们的头的行
 LastCol = FindLastCol（Data）
 StopRow = FindFirstBlankInCol（BlankCol，HeaderRow，Data）
 
'理智c heck：如果第一个空格超过我们的安全号码，
'我们可能会输入错误的BlankCol 
 ErrorCheck = 0 
如果StopRow> SafetyCheckBlank然后
 ErrorCheck = MsgBox（Dang！列中的第一个空白行& _ 
 BlankCol&超过& SafetyCheckBlank& _ 
你确定要运行这个& _ 
脚本吗？，vbYesNo，这是很多行！
如果ErrorCheck = vbNo然后退出Sub 
 End If 
 
'确定我们有多少组
使用Data 
设置GroupRange = .Range（.Cells（HeaderRow，GroupCol），.Cells（StopRow，GroupCol））
 GroupRange.AdvancedFilter操作：= xlFilterInPlace，唯一：= True 
 GroupRange.SpecialCells（xlCellTypeVisible）中的每个单元格
如果Cell.Value<> GroupHeaderName然后
 Uniques.Add（Cell.Value）
 End If 
下一个单元格
结束
调用ClearAllFilters（Data）
 
'理智检查：如果有超过25个独特团体，我们真的要
'超过25张吗？提示用户... 
 ErrorCheck = 0 
如果Uniques.Count> SafetyCheckUniques然后
 ErrorCheck = MsgBox（哇！你有& Uniques.Count&组在列& _ 
 GroupCol&，这超过了& SafetyCheckUniques & _ 
（这是很多结果的表格），你确定你要& _ 
要运行这个脚本吗？，vbYesNo，这是很多的工作表） 
如果ErrorCheck = vbNo然后退出Sub 
结束如果
 
'通过唯一集合循环，过滤每个唯一的数据块
'并将结果复制到新表
数据
设置DataBlock = .Range（.Cells（HeaderRow，GroupCol），.Cells（StopRow，LastCol））
结束
 Application.DisplayAlerts = False 
索引= 1到Uniques.Count 
调用ClearAllFilters（数据）
'确保工作表不存在...删除工作表如果找到
如果DoesSheetExist（ Unisite（Index））然后
 ThisW orkbook.Worksheets（CStr（Uniques（Index）））。删除
 End If 
'现在构建工作表并复制数据
 Set Target = ThisWorkbook.Worksheets.Add 
 Target.Name = Uniques（Index）
 DataBlock.AutoFilter字段：= GroupCol，Criteria1：= Uniques（Index）
 DataBlock.SpecialCells（xlCellTypeVisible）.Copy Destination：= Target.Cells（1，1） 
下一个索引
 Application.DisplayAlerts = True 
调用ClearAllFilters（数据）
 
 End Sub 
 
 
'INPUT：a工作表名称（字符串）
'返回：根据是否在此工作簿中找到工作表，true或false 
'SPECIAL CASE：none 
公共函数DoesSheetExist（dseSheetName As String）As Boolean 
 Dim obj As Object 
 On Error Resume Next 
'如果有错误，工作表不存在
设置obj = ThisWorkbook.Worksheets（dseSheetName）
如果Err = 0然后
 DoesSheetExist = True 
 Else 
 DoesSheetExist = False 
结束如果
错误GoTo 0 
结束函数
 
'INPUT：要检查的列号（长），我们应该在（长）
 '和工作表都存在于
'RETURN：第一个空格的行号
'SPECIAL CASE：如果列号为<= 0，则返回0，
'如果标题行为< = 0，
'如果表不存在则返回0 
公共函数FindFirstBlankInCol（ffbicColNumber As Long，ffbicHeaderRow As Long，_ 
 ffbicWorksheet As Worksheet）As Long 
如果ffbicColNumber <= 0或ffbicHeaderRow< = 0然后
 FindFirstBlankInCol = 0 
结束If 
如果不是，那么
 FindFirstBlankInCol = 0 
结束如果
'使用xl，将落在空白
之前的最后一行使用ffbicWorksheet 
 FindFirstBlankInCol = .Cells（ffbicHeaderRow，ffbicColNumber）.End（xlDown）.Row 
结束
结束函数
 
'INPUT：用于标识最后一列的工作表
'RETURN：工作表上最后一个占用单元格的列（作为一个长）
'SPECIAL CASE：return 1如果工作表为空
公共功能FindLastCol（flcSheet As Worksheet）As Long 
如果Application.WorksheetFunction.CountA（flcSheet.Cells）<> 0然后
 FindLastCol = flcSheet.Cells.Find（*，SearchOrder = = xlByColumns，SearchDirection：= xlPrevious）.Column 
 Else 
 FindLastCol = 1 
 End If 
结束函数
 
'INPUT：安全地清除过滤器的目标工作表
'TASK：清除所有过滤器
 Sub ClearAllFilters（cafSheet As Worksheet）
 with cafSheet 
 .AutoFilterMode = False 
如果.FilterMode = True然后
 .ShowAllData 
如果
结束
结束Sub 
  

Suppose I have a worksheet with multiple different values in Column A. Is there a way to create a macro that takes all rows with column entry 0 and puts them in a separate sheet, all with entry 1 in another sheet and so on? My first instinct is to create something that:

1) Sorts by the column in question

2) Uses an IF statement to check for the first location where the difference between the previous cell and the next cell is <> 0

3) Creates a new sheet, copies all the rows before the first difference <> 0 including the first cell in the calculation yielding a difference <> 0

4) Selects the new sheet and pastes the block of data in

5) Continues this process until a blank cell in a counter column DIFFERENT from the column being checked yields a blank value (this is because the column being sorted does have blank values)

Is there a better way to go about this? If not, any help would be appreciated in constructing the above. I will try to update this post with new code as I progress.

UPDATE: I think this is a step in the right direction, if anyone could advise that would be great.

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

解决方案

I think this design will get you where you're going... Consider a workbook that looks like this:

The script below will find a blank cell in column 2 (customizable in the code), then operates on the data block per your spec. There are some sanity checks built in, including a count of the unique groups (Do you really want more than 25 resultant sheets? The number is customizable in the code of course), and are you expecting to operate on more than 10,000 rows? (The row check is also customizable.)

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

这篇关于通过列值将数据分割成不同的表格的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！