Split Series

[ayazgreat]

Hi

I want to split a column series as per its left three 3 digits into different columns as example given below.

Excel Workbook
	A	B	C	D	E
1	Series	210	214	810	803
2	21000	21000	21400	81000	80300
3	21001	21001	21401	81000	80301
4	21002	21002	21402	81000	80302
5	21003	21003	21403	81000	80303
6	21004	21004	21404	81000
7	21005	21005	21405	81000
8	21400			81000
9	21401
10	21402
11	21403
12	21404
13	21405
14	81000
15	81000
16	81000
17	81000
18	81000
19	81000
20	81000
21	80300
22	80301
23	80302
24	80303
Sheet1

Could any body please help me ?

 

[ayazgreat]

Could anybody please resolve it?

 

[Beate Schmitz]

Macro with Advanced Filter

Hello,

my code provides that Columns("G:N") are unused/empty:

<div style="background-color:#FFFFFF; border-width:2px; border-style: groove; border-color:#ff9966; padding:4px;"><nobr><span style="font-family:Courier New,Arial; font-size:9pt ;" ><b><span style="color:#000080"; >Sub</span> Advanced_Filter()</b><br />    Columns(<span style="color:#800000"; >"B:E"</span>).Clear<br />    Range(<span style="color:#800000"; >"G1:N1"</span>).FormulaR1C1 = <span style="color:#800000"; >"Series"</span><br />    Range(<span style="color:#800000"; >"G2"</span>).FormulaR1C1 = <span style="color:#800000"; >">=21000"</span><br />    Range(<span style="color:#800000"; >"H2"</span>).FormulaR1C1 = <span style="color:#800000"; >"<21100"</span><br />    Range(<span style="color:#800000"; >"I2"</span>).FormulaR1C1 = <span style="color:#800000"; >">=21400"</span><br />    Range(<span style="color:#800000"; >"J2"</span>).FormulaR1C1 = <span style="color:#800000"; >"<21500"</span><br />    Range(<span style="color:#800000"; >"K2"</span>).FormulaR1C1 = <span style="color:#800000"; >">=81000"</span><br />    Range(<span style="color:#800000"; >"L2"</span>).FormulaR1C1 = <span style="color:#800000"; >"<81100"</span><br />    Range(<span style="color:#800000"; >"M2"</span>).FormulaR1C1 = <span style="color:#800000"; >">=80300"</span><br />    Range(<span style="color:#800000"; >"N2"</span>).FormulaR1C1 = <span style="color:#800000"; >"<80400"</span><br />    <br />    Range(<span style="color:#800000"; >"A:A"</span>).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _<br />        <span style="color:#800000"; >"G1:H2"</span>), CopyToRange:=Range(<span style="color:#800000"; >"B1"</span>), Unique:=False<br />    Range(<span style="color:#800000"; >"A:A"</span>).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _<br />        <span style="color:#800000"; >"I1:J2"</span>), CopyToRange:=Range(<span style="color:#800000"; >"C1"</span>), Unique:=False<br />    Range(<span style="color:#800000"; >"A:A"</span>).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _<br />        <span style="color:#800000"; >"K1:L2"</span>), CopyToRange:=Range(<span style="color:#800000"; >"D1"</span>), Unique:=False<br />    Range(<span style="color:#800000"; >"A:A"</span>).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _<br />        <span style="color:#800000"; >"M1:N2"</span>), CopyToRange:=Range(<span style="color:#800000"; >"E1"</span>), Unique:=False<br />    <br />    Range(<span style="color:#800000"; >"B1"</span>).FormulaR1C1 = <span style="color:#800000"; >"210"</span><br />    Range(<span style="color:#800000"; >"C1"</span>).FormulaR1C1 = <span style="color:#800000"; >"214"</span><br />    Range(<span style="color:#800000"; >"D1"</span>).FormulaR1C1 = <span style="color:#800000"; >"810"</span><br />    Range(<span style="color:#800000"; >"E1"</span>).FormulaR1C1 = <span style="color:#800000"; >"803"</span><br />    Columns(<span style="color:#800000"; >"G:N"</span>).Clear<br /><b><span style="color:#000080"; >End</span> <span style="color:#000080"; >Sub</span></b><br /></span></nobr></div><br/><div style=" background-color:#f8f8f8; border-width:2px; border-style: groove; border-color:#ff9966; padding:4px; width:300px;" >Codehighlighting with <a href="http://www.haserodt.de/cj_pro/cjdirect.php" >CodeJeanieDirectHtml</a></div>

 

[Legacy 68668]

Re: Macro with Advanced Filter

try

Sub test()
Dim a, e, w(), z As String, x, y, i As Long
With Range("a1").CurrengRegion.Resize(, 1)
    a = .Value
    With CreateObject("Scripting.Dictionary")
        For Each e In a
            z = Left(e, 3)
            If Not .exists(e) Then
                ReDim w(1 To 1) : w(1) = e
                .add z, w
            Else
                w = .item(z) : ReDim Preserve w(1 To UBound(w) + 1)
                w(UBound(w)) = e : .item(z) = w
            End If
        Next
        x = .keys : y = .items
    End With
    With .Offset(, .Columns.Count)
        .Resize(, UBound(x) + 1).ClearContents
        For i = 0 To UBound(x)
            .Offset(, i).Value = x(i)
            .Offset(1, i).Resize(UBound(y(i), 2), UBound(y(i), 1)).Value = _
            Application.Transpose(y(i))
        Next
    End With
End With
End Sub

 

[ayazgreat]

Thanks Seiya

But there is an error messege in your code in this line "Object does not support this property or methoed"

With Range("a2").CurrengRegion.Resize(, 1)

 

[Legacy 68668]

With Range("a1").CurrentRegion.Resize(, 1)

 

[ayazgreat]

Now error at this line

"This key is already associated with an element of this collection"

.Add z, w

 

[Legacy 68668]

Hummm typo...

Sub test()
Dim a, e, w(), z As String, x, y, i As Long
With Range("a2").CurrentRegion.Resize(, 1)
    a = .Value
    With CreateObject("Scripting.Dictionary")
        For Each e In a
            z = Left(e, 3)
            If Not .exists(z) Then
                ReDim w(1 To 1) : w(1) = e
                .add z, w
            Else
                w = .item(z) : ReDim Preserve w(1 To UBound(w) + 1)
                w(UBound(w)) = e : .item(z) = w
            End If
        Next
        x = .keys : y = .items
    End With
    With .Offset(, .Columns.Count)
        .Resize(, UBound(x) + 1).ClearContents
        With .Resize(1, 1)
            For i = 0 To UBound(x)
                .Offset(, i).Value = x(i)
                .Offset(1, i).Resize(UBound(y(i))).Value = _
                Application.Transpose(y(i))
            Next
        End With
    End With
End With
End Sub

 

[ayazgreat]

Thank you very much Seiya it works great

But it is also spliting text in colunm a1 as mentioned below in column b

Excel Workbook
	A	B	C	D	E	F	G
1	Series	Ser	210	214	810	803
2	21000	Series	21000	21400	81000	80300
3	21001		21001	21401	81000	80301
4	21002		21002	21402	81000	80302
5	21003		21003	21403	81000	80303
6	21004		21004	21404	81000
7	21005		21005	21405	81000
8	21400				81000
9	21401
10	21402
11	21403
12	21404
13	21405
14	81000
15	81000
16	81000
17	81000
18	81000
19	81000
20	81000
21	80300
22	80301
23	80302
24	80303
Sheet1

 

[Legacy 68668]

change

With Range("a2").CurrentRegion.Resize(, 1)
    a = .Value

to

With Range("a2").CurrentRegion.Resize(, 1)
    a = .Resize(.Rows.Count - 1).Offset(1).Value