Can someone help? (urgently needed)

rainx

rainx

Board Regular
Joined
Jul 4, 2008
Messages
210
Hi, I have a problem here, I have a list of entries of which has different group names. I need to sort them into various files based on their group name. In a way, doing filter, However, my concern is my group names will vary every month and I also need the files to be save respectively at a place with their group name. Kinda tough, Hope someone would be able to provide some advice. Wondering if it can just filter those that are in the list into different files instead of providing a fixed list to do for all each time. Please Help!

Thanks!
<!-- / message --> <!-- sig --> __________________
Cheers
Rainx
 
Sort by date Sort by votes

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
Hi

Due to the fact that I have 3 codename for 1 particular group, So i need to run another macro to then split the 3 codes into different sheets. I try to play around with the code you gave me but not able to work. Hope you can tell me how to change it to the way I want.

Thanks!
 
Upvote 0
rainx - I don't understand what you're asking. Can you do another screen grab to illustrate the problem, please?
 
Upvote 0
Ok.

Assume the following sample data:

<table x:str="" style="border-collapse: collapse; width: 134pt;" width="178" border="0" cellpadding="0" cellspacing="0"><col style="width: 86pt;" width="114"> <col style="width: 48pt;" width="64"> <tbody><tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt; width: 86pt;" width="114" height="17">Code</td> <td class="xl24" style="width: 48pt;" width="64">Name</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">155</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">155</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">155</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">155</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">155</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">155</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">155</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">155</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">155</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">155</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">189</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">189</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">189</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">189</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">189</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">189</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">189</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">189</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">189</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">189</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">189</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">189</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">189</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">189</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">189</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">177</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">177</td> <td class="xl24">Apple</td> </tr> <tr style="height: 12.75pt;" height="17"> <td class="xl24" style="height: 12.75pt;" x:num="" height="17">177</td> <td class="xl24">Apple</td> </tr> </tbody></table>
This is after I have group that categorised under Apple into a new workbook. However, there are 3 types of code belonging to apply, so i wan to do a further split into 3 sheets with the individual code. Does that make the picture clearer?

Thanks!
 
Upvote 0
If it's just one of the new workbooks that need to be split further, I would suggest running the code again on this workbook changing the following lines appropriately:

Code: 
sDataSheet = "Data" 'change this to the name of your sheet holding the original data
sCurrencyField = "Currency" 'change this to the title of your currency field
iCurrencyColumn = 1 'change this to the column number of your currency column

If all your data actually need to be filtered to workbooks based on changes in 2 columns, that will need a bit more tweaking. Details of the layout of your real data would be helpful in this case.
 
Upvote 0
actually, it will depends, but the flow goes this way, I will first split into workbooks according to their name. Then I will manually go into each file to check for those with that has more den 1 code for the same name. So I was tinking how to have a macro that will split into sheets that will work for any workbook. Yup, hope you get wad I mean?

Thanks anyway!
 
Upvote 0
Okay - you haven't given me any more details on the layout of your data, so you'll have to tweak this to fit. It assumes the two columns to be filtered are next to each other.

Code: 
Sub FilterMacroToNewBooksTwoColumns()
 
Dim ws As Worksheet
Dim wb As Workbook
Dim rCellCounter As Range
Dim sDataSheet As String, sPath As String, sFilterField1 As String, SFilterField2 As String, sFilename As String
Dim iFilterColumn1 As Integer
 
sDataSheet = "Data" 'change this to the name of your sheet holding the original data
sFilterField1 = "Currency" 'change this to the title of first filter field
SFilterField2 = "Code" 'change this to the title of second filter field (must be immediately to right of first filter field)
iFilterColumn1 = 1 'change this to the column number of your first filter column

Application.ScreenUpdating = False
 
Set wb = ActiveWorkbook
sPath = ActiveWorkbook.Path
 
'Delete any existing currency sheets
Application.DisplayAlerts = False
For Each ws In Worksheets
    If ws.Name <> sDataSheet Then ws.Delete
Next ws
Application.DisplayAlerts = True
 
'Create currency sheets
Set ws = Sheets.Add(After:=Worksheets(Worksheets.Count))
ws.Name = "Temp"
Union(Sheets(sDataSheet).Columns(iFilterColumn1), Sheets(sDataSheet).Columns(iFilterColumn1 + 1)).AdvancedFilter Action:=xlFilterCopy, _
    criteriarange:="", CopyToRange:=Sheets("Temp").Range("A1"), Unique:=True
'must include criteriarange - advanced filter "remembers" the last settings
 
'Filter on to each sheet
For Each rCellCounter In Sheets("Temp").Range("A1").CurrentRegion.Resize(, 1)
    If rCellCounter.Value <> sFilterField1 Then
        Set ws = Sheets.Add(After:=Worksheets(Worksheets.Count))
        ws.Name = rCellCounter.Value & " " & rCellCounter.Offset(0, 1).Value
        ws.Range("a1").Value = sFilterField1
        ws.Range("a2").Value = rCellCounter.Value
        ws.Range("b1").Value = SFilterField2
        ws.Range("b2").Value = rCellCounter.Offset(0, 1).Value
        Sheets(sDataSheet).Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
            criteriarange:=ws.Range("A1:B2"), CopyToRange:=ws.Range("A4"), Unique:=False
        ws.Rows("1:3").Delete
    End If
Next rCellCounter
 
Application.DisplayAlerts = False
Sheets("Temp").Delete
Application.DisplayAlerts = True
 
For Each ws In Worksheets
    If ws.Name <> sDataSheet Then
        sFilename = ws.Name
        ws.Move
        ActiveWorkbook.SaveAs sPath & "\" & sFilename & ".xls"
    End If
Next ws
 
wb.Sheets(sDataSheet).Activate 'just for aesthetics
 
Application.ScreenUpdating = True
 
End Sub
 
Upvote 0
cornflakegirl said:
Okay - you haven't given me any more details on the layout of your data, so you'll have to tweak this to fit. It assumes the two columns to be filtered are next to each other.

Code: 
Sub FilterMacroToNewBooksTwoColumns()
 
Dim ws As Worksheet
Dim wb As Workbook
Dim rCellCounter As Range
Dim sDataSheet As String, sPath As String, sFilterField1 As String, SFilterField2 As String, sFilename As String
Dim iFilterColumn1 As Integer
 
sDataSheet = "Data" 'change this to the name of your sheet holding the original data
sFilterField1 = "Currency" 'change this to the title of first filter field
SFilterField2 = "Code" 'change this to the title of second filter field (must be immediately to right of first filter field)
iFilterColumn1 = 1 'change this to the column number of your first filter column

Application.ScreenUpdating = False
 
Set wb = ActiveWorkbook
sPath = ActiveWorkbook.Path
 
'Delete any existing currency sheets
Application.DisplayAlerts = False
For Each ws In Worksheets
    If ws.Name <> sDataSheet Then ws.Delete
Next ws
Application.DisplayAlerts = True
 
'Create currency sheets
Set ws = Sheets.Add(After:=Worksheets(Worksheets.Count))
ws.Name = "Temp"
Union(Sheets(sDataSheet).Columns(iFilterColumn1), Sheets(sDataSheet).Columns(iFilterColumn1 + 1)).AdvancedFilter Action:=xlFilterCopy, _
    criteriarange:="", CopyToRange:=Sheets("Temp").Range("A1"), Unique:=True
'must include criteriarange - advanced filter "remembers" the last settings
 
'Filter on to each sheet
For Each rCellCounter In Sheets("Temp").Range("A1").CurrentRegion.Resize(, 1)
    If rCellCounter.Value <> sFilterField1 Then
        Set ws = Sheets.Add(After:=Worksheets(Worksheets.Count))
        ws.Name = rCellCounter.Value & " " & rCellCounter.Offset(0, 1).Value
        ws.Range("a1").Value = sFilterField1
        ws.Range("a2").Value = rCellCounter.Value
        ws.Range("b1").Value = SFilterField2
        ws.Range("b2").Value = rCellCounter.Offset(0, 1).Value
        Sheets(sDataSheet).Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
            criteriarange:=ws.Range("A1:B2"), CopyToRange:=ws.Range("A4"), Unique:=False
        ws.Rows("1:3").Delete
    End If
Next rCellCounter
 
Application.DisplayAlerts = False
Sheets("Temp").Delete
Application.DisplayAlerts = True
 
For Each ws In Worksheets
    If ws.Name <> sDataSheet Then
        sFilename = ws.Name
        ws.Move
        ActiveWorkbook.SaveAs sPath & "\" & sFilename & ".xls"
    End If
Next ws
 
wb.Sheets(sDataSheet).Activate 'just for aesthetics
 
Application.ScreenUpdating = True
 
End Sub
Click to expand...


I dun tink the filter is working.. after running, no entries appear, mm, actually my layout is like the sample data i posted up there. with 3 codes belonging to apple after i run the data for it to split into workbooks, so nw I wanted to filter each code into 1 sheet within the same workbook.
 
Upvote 0
Rainx - mentioning earlier that you wanted the second filter to just split to sheets would have been helpful.

I'm questioning your layout because the layout you first posted had Fruit in the first column - then later it moved to the second column. The code assumes that filter field 1 is column 1 and filter field 2 is column 2 (although this can obviously be adjusted in the code).

The code does work. I've tested it on a sample workbook with a layout as I've described.

I don't know if I'll have a chance to look at this again today. Maybe you should have a play with the code and see if you can tweak it to do what you want?
 
Upvote 0
Different approach
try
Code: 
Sub test()
Dim a, i As Long, ii As Long, w(), e
a = Range("a1").CurrentRegion.Resize(,3).Value
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 2 To UBound(a,1)
        If Not IsEmpty(a(i,1)) Then
            If Not .exists(a(i,1)) Then
                ReDim w(1 To UBound(a,2), 1 To 1)
                For ii = 1 To UBound(a,2) : w(ii, 1) = a(i,ii) : Next
                .add a(i,1), w
            Else
               w = .item(a(i,1))
               ReDim Preserve w(1 To UBound(a,2), 1 To UBound(w,2) + 1)
               For ii = 1 To UBound(a,2) : w(ii, UBound(w,2)) = a(i,ii) : Next
               .item(a(i,1)) = w
           End If
        End If
    Next
    For Each e In .keys
        w = .item(e)
        Set wb = Workbooks.Add
        wb.Sheets(1).Cells(1).Resize(UBound(w,2), UBound(w,1)).Value = _
            Application.Transpose(w)
        wb.SaveAs ThisWorkbook.Path & "\" & e & ".xls"
        wb.Close False
    Next
End With
End Sub
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Question
'How to' question about a Dashboard
Replies
5
Views
236
etaf
etaf
S
  • Question
Can a macro help create a user hierarchy?
Replies
7
Views
205
Akuini
Akuini
M
  • Question
Excel pivot table query - retaining filters on pivot in absence of data
2
Replies
10
Views
1K
Alex Blakenburg
A
G
  • Solved
VBA to allow grouping +- after reopening of the sheet
Replies
7
Views
788
Greenbehindthecells
G
R
  • Question
Can you help with this code please?
Replies
3
Views
128
rlv01
R

Forum statistics

Threads
1,215,237
Messages
6,123,800
Members
449,127
Latest member
Cyko

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top