Divide the data into different sheets by column values

advertisements

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