Help me with Macro please

Let say i have an excel file called Main
The file has a single sheet called Data
The sheet has about four columns, the last one is City
Like example how the file looksi want to run the macro which will automatically filter the Data sheet by City
It always two city so it means it should add two additional sheets: Data LA and Data San Diego.
After running the macro the book will have three tabs/sheets:
Data----------------original
Data LA------------ filtered by City where City is LA
Data San Diego--filtered by City where City is San Diego
Main.xls
rfedorovAsked:
Who is Participating?
 
nutschCommented:
Hi, the attached macro will do what you need.

Thomas
Sub SplitListIntoWorksheets()
'split list into individual worksheets
Dim lastROw As Long, i As Long
Dim shtData As Worksheet, lgCol As Long, rgSel As Range
Dim cUnique As New Collection
Const blTitles As Boolean = True                    'true if the data has titles, false otherwise
Const sColumn As String = "D"                       'Which column should the list be split on

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

lgCol = Cells(1, sColumn).Column
Set rgSel = Cells(1, 1).CurrentRegion

lastROw = Cells(Rows.Count, lgCol).End(xlUp).Row 'get last row

Set shtData = ActiveSheet

'load the column contents in a collection, to keep individual values
On Error Resume Next

For i = 2 To lastROw
    If Cells(i, lgCol) <> Cells(i - 1, lgCol) Then
        cUnique.Add Cells(i, lgCol), CStr(Cells(i, lgCol))
    End If
Next

On Error GoTo 0

'for each individual value, filter the list, copy the results to a new workbook, save and close the new workbook
For i = 1 To cUnique.Count
    shtData.AutoFilterMode = False
    rgSel.CurrentRegion.AutoFilter Field:=lgCol - rgSel.CurrentRegion.Column + 1, Criteria1:=cUnique(i)
    Set shtDest = Sheets.Add
    shtDest.Name = "Data " & cUnique(i)
    rgSel.CurrentRegion.Copy shtDest.Cells(1, 1)
Next

shtData.AutoFilterMode = False

Application.ScreenUpdating = True 'reenable ScreenUpdating
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub

Open in new window

0
 
Ardhendu SarangiSr. Project ManagerCommented:
Try the following code -  this should work for you.

thanks,
Ardhendu
Sub FilterMe()
'
' Macro1 Macro
'
    On Error Resume Next
    Application.DisplayAlerts = False
    Set ws1 = Sheets("Data")
    ws1.Activate
    ws1.Range("A1").Select
    ActiveWorkbook.Worksheets("Data").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Data").Sort.SortFields.Add Key:=Range("D2:D3000"), _
                                                          SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Data").Sort
        .SetRange Range("A1:D3000")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ws1.Columns("D:D").Copy
    ws1.Range("H1").PasteSpecial
    Application.CutCopyMode = False
    ws1.Range("$H$1:$H$3000").RemoveDuplicates Columns:=1, Header:=xlYes
    For i = 2 To ws1.Cells(65536, "H").End(xlUp).Row
        Sheets("Data City-" & Range("H" & i)).Delete
        Sheets.Add
        Set ws2 = ActiveSheet
        ws2.Name = "Data City-" & ws1.Range("H" & i)
        ws1.Range("A1:E1").Copy
        ws2.Range("A1").PasteSpecial
        Application.CutCopyMode = False
        For j = 2 To ws1.Cells(65536, "D").End(xlUp).Row
            If ws1.Range("D" & j) = ws1.Range("H" & i) Then
                ws1.Range("A" & j & ":D" & j).Copy
                k = ws2.Cells(65536, "A").End(xlUp).Row + 1
                ws2.Range("A" & k).PasteSpecial
                Application.CutCopyMode = False
            End If
        Next
    Next
    ws1.Columns("H:H").Delete
    Application.DisplayAlerts = True
    MsgBox ("Done!")
End Sub

Open in new window

Main.xls
0
 
rlarianCommented:
try this (ugly, but it will get you in the right direction)
Main.xlsm
0
 
rfedorovAuthor Commented:
Thank you,
To nutsch, your solution is the best
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.