Can someone help? (urgently needed)

[rainx]

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

 

[cornflakegirl]

Wow, that's fast!
I don't know anything about using dictionaries, so will have to study it later.

It doesn't quite do what Rainx is asking for though - he wants to filter on two columns. Filtering on the first creates a new book for each name (as your code does). He then wants to filter again on the second field, creating a new sheet within each new book for each name in the second field.

So if the data is:
Apple A 1
Apple A 2
Apple B 1
Apple B 2
Apple B 3
Pear C 1
Pear C 2
Pear D 1
Pear E 1

There would be two books - Apple and Pear. Apple would have two sheets - A and B. Pear would have three sheets - C, D and E.

 

[jindon]

I see...

Sub test()
Dim a, i As Long, ii As Long, iii As Long, w(), e, x, y, z()
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
    x = .keys : y = .items : .removeall
End With
For i = 0 To UBound(x)
    w = y(i)
    Set wb = Workbooks.Add
    For ii = 1 To UBound(w,2)
        If Not .exists(w(1,ii)) Then
            ReDim z(1 To UBound(w,1), 1 To 1)
            For iii = 1 To UBound(w,1) : z(iii,1) = w(iii,ii) : Next
            .add w(1,ii) , z
        Else
            z = .item(w(1,ii))
            ReDim Preserve z(1 To UBound(w,1), UBound(z,2) + 1)
            For iii = 1 to UBound(w,1) : z(iii, UBound(z,2)) = w(iii,ii) : Next
        End If
    Next
    For Each e In .keys
        z = .item(e)
        Set ws = wb.Sheets.Add before = wb.Sheets(1)
        ws.Name = e
        ws.Cells(1).Resize(UBound(z,2), UBound(z,1)).Value = _
            Application.Transpose(z)
    Next
    wb.SaveAs ThisWorkbook.Path & "\" & x(i) & ".xls"
    .removeall
Next
End Sub

 

[cornflakegirl]

Jindon - just tried your code - I get a compile error - Invalid or unqualified reference - it picks out .exists in this line:
If Not .exists(w(1,ii)) Then

Am I doing something wrong?

 

[jindon]

Yup!
should be

Sub test()
Dim a, i As Long, ii As Long, iii As Long, w(), e, x, y, z()
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
    x = .keys : y = .items : .removeall
    For i = 0 To UBound(x)
        w = y(i)
        Set wb = Workbooks.Add
        For ii = 1 To UBound(w,2)
            If Not .exists(w(1,ii)) Then
                ReDim z(1 To UBound(w,1), 1 To 1)
                For iii = 1 To UBound(w,1) : z(iii,1) = w(iii,ii) : Next
                .add w(1,ii) , z
            Else
                z = .item(w(1,ii))
                ReDim Preserve z(1 To UBound(w,1), UBound(z,2) + 1)
                For iii = 1 to UBound(w,1) : z(iii, UBound(z,2)) = w(iii,ii) : Next
            End If
        Next
        For Each e In .keys
            z = .item(e)
            Set ws = wb.Sheets.Add before = wb.Sheets(1)
            ws.Name = e
            ws.Cells(1).Resize(UBound(z,2), UBound(z,1)).Value = _
                Application.Transpose(z)
        Next
        wb.SaveAs ThisWorkbook.Path & "\" & x(i) & ".xls"
        .removeall
    Next
End With
End Sub

Hope this works
I need to go now, so if any bugs, I'll reply tomorrow.

 

[cornflakegirl]

For tomorrow:

I'm now getting Runtime error 9: Subscript out of range
for
ReDim Preserve z(1 To UBound(w, 1), UBound(z, 2) + 1)

 

[jindon]

Few other alteration, too

Sub test()
Dim a, i As Long, ii As Long, iii As Long
Dim w(), e, x, y, z(), n As Long, wb As Workbook
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
    x = .keys : y = .items : .removeall
    For i = 0 To UBound(x)
        w = y(i)
        For ii = 1 To UBound(w,2)
            If Not .exists(w(2,ii)) Then
                ReDim z(1 To UBound(w,1), 1 To 1)
                For iii = 1 To UBound(w,1) : z(iii,1) = w(iii,ii) : Next
                .add w(2,ii) , z
            Else
                z = .item(w(2,ii))
                ReDim Preserve z(1 To UBound(w,1), 1 To UBound(z,2) + 1)
                For iii = 1 to UBound(w,1) : z(iii, UBound(z,2)) = w(iii,ii) : Next
            End If
        Next
        Set wb = Workbooks.Add
        For Each e In .keys
            n = n + 1
            If n > wb.Sheets.Count Then wb.Sheets.Add _
                            after:=wb.Sheets(wb.Sheets.Count)
            z = .item(e)
            With wb.Sheets(n)
                    .Name = e
                    .Cells(1).Resize(UBound(z,2), UBound(z,1)).Value = _
                         Application.Transpose(z)
            End With
        Next
        wb.SaveAs ThisWorkbook.Path & "\" & x(i) & ".xls"
        .removeall : n = 0
    Next
End With
End Sub

 

[rainx]

Somehow it is only showing 1 entry for each.

Anyway, I do not need the code for splitting into workbook already. I only need the codes for splitting into different sheets within the same workbook for the diff code that belong to for example apple.

 

[rainx]

It is filtering into different workbooks instead of different sheets within the same workbook.

 

[jindon]

Sub test()
Dim a, i As Long, ii As Long, w(), e, ws As Worksheet
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)
        On Error Resume Next
        Application.DisplayAlerts = False
        Sheets(e).Delete
        Application.DisplayAlerts = True
        On Error GoTo 0
        Set ws = Sheets.Add
        ws.Name = e
        ws.Cells(1).Resize(UBound(w,2), UBound(w,1)).Value = _
            Application.Transpose(w)
    Next
End With
End Sub

 

[cornflakegirl]

rainx - I'm not suggesting this as an improved method over jindon's, because a code that filters column 1 to new books and column 2 to new sheets is definitely the way to go.

But, if you really do want code to just split the Apple book to different sheets, this will do it:

Sub FilterMacro()
Dim ws As Worksheet
Dim rCellCounter As Range
Dim sDataSheet As String
Dim sFilterField As String
Dim iFilterColumn As Integer
sDataSheet = "Data" 'change this to the name of your sheet holding the original data
sFilterField = "Currency" 'change this to the title of your filter field
iFilterColumn = 1 'change this to the column number of your filter column
Application.ScreenUpdating = False
'Delete any existing currency sheets
Application.DisplayAlerts = False
For Each ws In Worksheets
    If ws.Name <> sDataSheet And ws.Name <> "Fazza" Then ws.Delete
Next ws
Application.DisplayAlerts = True
'Create currency sheets
Set ws = Sheets.Add(After:=Worksheets(Worksheets.Count))
ws.Name = "Temp"
Sheets(sDataSheet).Columns(iFilterColumn).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
    If rCellCounter.Value <> sFilterField Then
        Set ws = Sheets.Add(After:=Worksheets(Worksheets.Count))
        ws.Name = rCellCounter.Value
        ws.Range("a1").Value = sFilterField
        ws.Range("a2").Value = rCellCounter.Value
        Sheets(sDataSheet).Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
            criteriarange:=ws.Range("A1:A2"), copyToRange:=ws.Range("A4"), Unique:=False
        ws.Rows("1:3").Delete
    End If
Next rCellCounter
Application.DisplayAlerts = False
Sheets("Temp").Delete
Application.DisplayAlerts = True
Sheets(sDataSheet).Activate 'just for aesthetics
Application.ScreenUpdating = True
End Sub