Separate records in multiple tabs by city

[dstrickland91]

All,

Was wondering if I could get some help with this. I get a report with 60K-70K rows of names addresses etc...

I like to separate that sheet into multiple sheets by city. Sometimes there are 10-15 citys so it can take a while filtering, copy and pasting. Can we create a code that will do this? Column D contains the city and Row 1 has my headers. I would like for the headers to exist on each sheet. I would also like it to rename each tab by the city name, so I assume something like Sheets.Name= Range("D2") would be somewhere in there after the code has ran?

I appreciate any help.

 

[onlyadrafter]

Hello,

does this work as expected?

Sub SORT_CITIES()
    Application.ScreenUpdating = False
    For MY_ROWS = 2 To Range("D" & Rows.Count).End(xlUp).Row
        MY_CITY = Range("D" & MY_ROWS).Value
        For MY_SHEETS = 1 To ActiveWorkbook.Sheets.Count
            If Sheets(MY_SHEETS).Name = MY_CITY Then
                GoTo FOUND:
            End If
        Next MY_SHEETS
        Worksheets.Add After:=Sheets(ActiveWorkbook.Sheets.Count)
        ActiveSheet.Name = MY_CITY
        Sheets("Sheet1").Activate
        Rows(1).Copy Sheets(MY_CITY).Range("A1")
FOUND:
        Rows(MY_ROWS).Copy Sheets(MY_CITY).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    Next MY_ROWS
    Application.ScreenUpdating = True
End Sub

you will need to change Sheet1 to the sheet name of your list.

 

[JLGWhiz]

Try this

Sub breakout()
Dim sh As Worksheet, lr As Long, c As Range
Set sh = Sheets(1) 'Edit sheet name - this is the report
lr = sh.Cells(Rows.Count, 4).End(xlUp).Row
With sh
    .Range("D1:D" & lr).AdvancedFilter xlFilterCopy, , .Range("D" & lr + 2), True
    For Each c In .Range("D" & lr + 3, .Cells(Rows.Count, 4).End(xlUp))
        .UsedRange.AutoFilter 4, c.Value
        If .UsedRange.SpecialCells(xlCellTypeVisible).Count > 1 Then
            Sheets.Add After:=ThisWorkbook.Sheets(Sheets.Count)
            ActiveSheet.Name = c.Value
            .Range("A1:A" & lr).SpecialCells(xlCellTypeVisible).EntireRow.Copy ActiveSheet.Range("A1")
        End If
        .AutoFilterMode = False
    Next
End With
End Sub

 

[dstrickland91]

Yes this does work! Thanks. My only question is it seems to run quite slow compared to some codes I have that do much more extensive work from sorting, formatting countif then delete etc.... I even narrowed the data down to 8k rows to see if it improved. Any idea what may be slowing it down?

Quick note: I want to thank you for actually helping, I dont want to come off as if I'm not grateful for the code you've done so far...

 

[dstrickland91]

JLGWhiz, unfortunately this does not work. Im getting a 1004 on this line...

.Range("y1:y" & lr).AdvancedFilter xlFilterCopy, , .Range("y" & lr + 2), True


I changed Column D to Column Y fyi....

 

[dstrickland91]

Onlyadrafter, Your code was the code I was stating worked perfect but ran pretty slow. I didnt realize JLG responded also.

Sorry for any confusion.

 

[dmt32]

Hi,
see if this solution is any quicker.

Place all code in standard module:

Option Explicit


Sub FilterData()
    Dim ws1Master As Worksheet, wsNew As Worksheet, wsFilter As Worksheet
    Dim Datarng As Range, FilterRange As Range, objRange As Range
    Dim rowcount As Long
    Dim colcount As Integer, FilterCol As Integer, FilterRow As Long
    Dim SheetName As String




    'master sheet
    Set ws1Master = ActiveSheet


    'set the Column you
    'are filtering
top:
    On Error Resume Next
    Set objRange = Application.InputBox("Select Field Name To Filter", "Range Input", , , , , , 8)
    On Error GoTo 0
    If objRange Is Nothing Then
        Exit Sub
    ElseIf objRange.Columns.Count > 1 Then
        GoTo top
    End If


    FilterCol = objRange.Column
    FilterRow = objRange.Row


    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With


    On Error GoTo progend


    'add filter sheet
    Set wsFilter = Sheets.Add
    With ws1Master
        .Activate
        .Unprotect Password:=""  'add password if needed
        
        rowcount = .Cells(.Rows.Count, FilterCol).End(xlUp).Row
        colcount = .Cells(FilterRow, .Columns.Count).End(xlToLeft).Column


        If FilterCol > colcount Then
            Err.Raise 65000, "", "FilterCol Setting Is Outside Data Range.", "", 0
        End If


        Set Datarng = .Range(.Cells(FilterRow, 1), .Cells(rowcount, colcount))
        'extract Unique values from FilterCol
        .Range(.Cells(FilterRow, FilterCol), _
               .Cells(rowcount, _
                      FilterCol)).AdvancedFilter _
                      Action:=xlFilterCopy, _
                      CopyToRange:=wsFilter.Range("A1"), _
                      Unique:=True
        rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
        'set Criteria
        wsFilter.Range("B1").Value = wsFilter.Range("A1").Value


        For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
            'check for blank cell in range
            If Len(FilterRange.Value) > 0 Then
                'add the FilterRange to criteria
                wsFilter.Range("B2").Value = FilterRange.Value
                SheetName = RTrim(Left(FilterRange.Value, 31))
                'if FilterRange sheet exists
                'update it
                If SheetExists(SheetName) Then
                    Sheets(SheetName).Cells.Clear
                Else
                    'add new sheet
                    Set wsNew = Sheets.Add(after:=Worksheets(Worksheets.Count))
                    wsNew.Name = SheetName
                End If
                Datarng.AdvancedFilter Action:=xlFilterCopy, _
                                       CriteriaRange:=wsFilter.Range("B1:B2"), _
                                       CopyToRange:=Sheets(SheetName).Range("A1"), _
                                       Unique:=False


            End If
        Next
        .Select
    End With


progend:
    wsFilter.Delete
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    If Err > 0 Then
        MsgBox (Error(Err)), 16, "Error"
        Err.Clear
    End If
End Sub


Function SheetExists(ByVal sh As String) As Boolean
'stock function
    On Error Resume Next
    SheetExists = CBool(Len(Worksheets(sh).Name) > 0)
    On Error GoTo 0
End Function

When run an Inputbox appears, just click with mouse of field heading (column) you want to filter & code should do rest for you.

Hope helpful

Dave

 

[dstrickland91]

DMT32, This is awesome. Almost instant. Thanks.

 

[dmt32]

DMT32, This is awesome. Almost instant. Thanks.

Most welcome glad solution helped.

code is designed to be universal to use with any worksheet where you have Field (column) headings - just select the heading you want to create separate sheets & code does the rest either adding new sheets or updating existing sheets.

Dave