Help me with Macro please

Posted on 2011-05-04
Last Modified: 2012-06-21
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 LA------------ filtered by City where City is LA
Data San Diego--filtered by City where City is San Diego
Question by:rfedorov
    LVL 20

    Assisted Solution

    Try the following code -  this should work for you.

    Sub FilterMe()
    ' Macro1 Macro
        On Error Resume Next
        Application.DisplayAlerts = False
        Set ws1 = Sheets("Data")
        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
        End With
        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
            Set ws2 = ActiveSheet
            ws2.Name = "Data City-" & ws1.Range("H" & i)
            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
        Application.DisplayAlerts = True
        MsgBox ("Done!")
    End Sub

    Open in new window

    LVL 39

    Accepted Solution

    Hi, the attached macro will do what you need.

    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
    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)
    shtData.AutoFilterMode = False
    Application.ScreenUpdating = True 'reenable ScreenUpdating
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    End Sub

    Open in new window

    LVL 4

    Assisted Solution

    try this (ugly, but it will get you in the right direction)

    Author Closing Comment

    Thank you,
    To nutsch, your solution is the best

    Featured Post

    Gigs: Get Your Project Delivered by an Expert

    Select from freelancers specializing in everything from database administration to programming, who have proven themselves as experts in their field. Hire the best, collaborate easily, pay securely and get projects done right.

    Join & Write a Comment

    Introduction This Article briefly covers methods of calculating the NPV and IRR variants in Excel as well as the limitations in calculating and interpreting IRR results. Paraphrasing Richard Shockley, author of my favourite finance reference tex…
    MS Access 2003 or later To MySQL Migration Project Hello All, this is my second article in the category of MS-OFFICE Automation. In internet I am not able to find any comprehensive resource on the Migration of MS Access back-end to MySQL so I fin…
    The viewer will learn how to simulate a series of sales calls dependent on a single skill level and learn how to simulate a series of sales calls dependent on two skill levels. Simulating Independent Sales Calls: Enter .75 into cell C2 – “skill leve…
    Graphs within dashboards are meant to be dynamic, representing data from a period of time that will change each time the dashboard is updated with new data. Rather than update each graph to point to a different set within a static set of data, t…

    745 members asked questions and received personalized solutions in the past 7 days.

    Join the community of 500,000 technology professionals and ask your questions.

    Join & Ask a Question

    Need Help in Real-Time?

    Connect with top rated Experts

    13 Experts available now in Live!

    Get 1:1 Help Now