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