# Divide the data into different sheets by column values

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
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 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
LastCol = FindLastCol(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))
For Each Cell In GroupRange.SpecialCells(xlCellTypeVisible)
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
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
Target.Name = Uniques(Index)
DataBlock.AutoFilter Field:=GroupCol, Criteria1:=Uniques(Index)
DataBlock.SpecialCells(xlCellTypeVisible).Copy Destination:=Target.Cells(1, 1)
Next Index
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
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