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

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

是的。这里有一些伪代码让你开始。

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教程。

Answer 3

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

首先，我们需要知道如何查看工作表是否存在，如果不存在，如何创建它。请注意，布尔类型隐式初始化为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