[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
?
Solved

Help me with Macro please

Posted on 2011-05-04
4
Medium Priority
?
336 Views
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----------------original
Data LA------------ filtered by City where City is LA
Data San Diego--filtered by City where City is San Diego
Main.xls
0
Comment
Question by:rfedorov
4 Comments
 
LVL 20

Assisted Solution

by:Ardhendu Sarangi
Ardhendu Sarangi earned 400 total points
ID: 35692502
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
 
LVL 39

Accepted Solution

by:
nutsch earned 1200 total points
ID: 35692536
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
 
LVL 4

Assisted Solution

by:rlarian
rlarian earned 400 total points
ID: 35692706
try this (ugly, but it will get you in the right direction)
Main.xlsm
0
 

Author Closing Comment

by:rfedorov
ID: 35702763
Thank you,
To nutsch, your solution is the best
0

Featured Post

Upgrade your Question Security!

Add Premium security features to your question to ensure its privacy or anonymity. Learn more about your ability to control Question Security today.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

You need to know the location of the Office templates folder, so that when you create new templates, they are saved to that location, and thus are available for selection when creating new documents.  The steps to find the Templates folder path are …
After seeing numerous questions for Dynamic Data Validation I notice that most have used Visual Basic to solve the problem. This suggestion is purely formula based and can be used in multiple rows.
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.
Although Jacob Bernoulli (1654-1705) has been credited as the creator of "Binomial Distribution Table", Gottfried Leibniz (1646-1716) did his dissertation on the subject in 1666; Leibniz you may recall is the co-inventor of "Calculus" and beat Isaac…

834 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