按列值將數據拆分到不同的表格

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