Splitting Data into Different Sheets by Column Values

Question

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

Answer 1

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

Answer 2

The code I'll post is certainly not perfect, but it will get you much closer to your goal.

First, we're going to need to know how to see if a worksheet exists and, if it doesn't, how to create it. Note that boolean types are implicitly initialized to 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

Next, we'll need to be able to find the last row for any given worksheet, so I'll take your code snippet and turn it into a function that accepts a worksheet object.

Private Function lastrow(ws As Worksheet) As Long
    lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
End Function

Finally, we'll pull it all together in our main routine. This loops through each cell in myRange (column G) creating destination sheets and sending values to the last available row in Column 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

Yes. Here's some pseudo code to get you started.

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

Feel free to post your attempts and we'll help you along the way. If you'd rather just pay for it, I'd be happy to send you a quote. :)

Google will provide a ton of tutorials in VBA, if you need more on the basics.