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

 

[rainx]

would b better if it is possible to duplicate the header to each of the split sheets... but if cant, its ok..

Thanks!

 

[jindon]

try

Sub test()
Dim a, i As Long, ii As Long, w(), e, ws As Worksheet
Dim HeaderRow As Long, FilterCol As Integer
HeaderRow = Application.InputBox("click on the header", type:=8).Row
FilterCol = Application.InputBox("click on the column to be filtered", type:=8).Column
With ActiveSheet
    a = .Range("a1", .SpecialCells(11)).Value
End With
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = HeaderRow + 1 To UBound(a,1)
        If Not IsEmpty(a(i,FilterCol)) Then
            If Not .exists(a(i,FilterCol)) 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,FilterCol), w
            Else
                w = .item(a(i,FilterCol))
                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,FilterCol)) = 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

 

[rainx]

Hmm, the column filtered is 1, the old code is ok, no need for the inputbox. As for the header right, can fixed it at the 1st 5 rows?, including the column headings..

Thanks!

 

[jindon]

Hi

Can I know which part should I change if the column I wan to filter is no longer Column 1?[/quote]

Hmm, the column filtered is 1, the old code is ok, no need for the inputbox. As for the header right, can fixed it at the 1st 5 rows?, including the column headings..

I'm lost.

 

[rainx]

Hi

Can I know which part should I change if the column I wan to filter is no longer Column 1?[/quote]



I'm lost.

The column I am filtering is column 1, the old code you posted was working fine.. now i only need to know how to cater for the header rows which is the 1st 5 rows...

 

[rainx]

Possible not to use inputbox? cos the header rows are always the 1st 5 rows.. yup..

THanks!

 

[jindon]

Do you want like this ?

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 = 6 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

 

[rainx]

Do you want like this ?

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 = 6 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

Er I try running, but nth happens...mm...duno why..

thanks..

 

[jindon]

Then try

Sub test()
Dim a, i As Long, ii As Long, w(), e, ws As Worksheet
Dim HeaderRow As Long
HeaderRow = 5
FilterCol=1
With ActiveSheet
    a = .Range("a1", .SpecialCells(11)).Value
End With
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = HeaderRow + 1 To UBound(a,1)
        If Not IsEmpty(a(i,FilterCol)) Then
            If Not .exists(a(i,FilterCol)) 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,FilterCol), w
            Else
                w = .item(a(i,FilterCol))
                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,FilterCol)) = 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

 

[rainx]

a = .Range("a1", .SpecialCells(11)).Value

there is error with tis line...