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]

Thanks it works great
Can it be possile to add each series count as mentioned below

Excel Workbook
	A	B	C	D	E	F	G
1	Series	210	214	810	803	808	809
2	21000	6	6	7	4	7	8
3	21001	21000	21400	81000	80300	80800	80900
4	21002	21001	21401	81000	80301	80801	80901
5	21003	21002	21402	81000	80302	80802	80902
6	21004	21003	21403	81000	80303	80803	80903
7	21005	21004	21404	81000		80804	80904
8	21400	21005	21405	81000		80805
9	21401			81000		80806
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
25	80800
26	80801
27	80802
28	80803
29	80804
30	80805
31	80806
32	80900
33	80901
34	80902
35	80903
36	80904
Sheet1

 

[Legacy 68668]

change

        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

to

        With .Resize(1, 1)
            For i = 0 To UBound(x)
                .Offset(, i).Resize(2).Value = _
                Application.Transpose(Array(x(i), UBound(y(i))))
                .Offset(2, i).Resize(UBound(y(i))).Value = _
                Application.Transpose(y(i))
            Next
        End With

 

[ayazgreat]

Thanks you very much, it works perfect

 

[ayazgreat]

Seiya

Can it be possibel that result of your macro "Numbers Store as Text" of all splited series ?

 

[facethegod]

you can also try...

Option Explicit
Sub tst()
Dim a, b, c() As String, x As Integer, m As Integer, ii As Integer, i As Integer, ac As New Collection, r As Range
With Application
Set r = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    With r
    a = Evaluate("=INDEX(LEFT(" & .Address & ",3),0,1)")
    b = .Value
    End With
For i = 1 To UBound(a, 1)
    On Error Resume Next
    ac.Add a(i, 1), CStr(a(i, 1))
Next
ReDim c(1 To UBound(a, 1), 1 To ac.Count): x = 2
For i = 1 To ac.Count
c(1, i) = ac.Item(i)
    Do Until IsError(.Match(ac.Item(i), a, 0))
    ii = .Match(ac.Item(i), a, 0): x = x + 1
    c(x, i) = b(ii, 1)
    a(ii, 1) = Empty
    Loop
c(2, i) = x - 2: m = .Max(x, m): x = 2
Next
End With
Range("C1").Resize(m, UBound(c, 2)) = c
End Sub

 

[ayazgreat]

Thanks facethegod it works perfect but i do not want thier counts to be number store as text

<TABLE style="PADDING-RIGHT: 2pt; PADDING-LEFT: 2pt; FONT-SIZE: 10pt; FONT-FAMILY: Arial,Arial; BACKGROUND-COLOR: #ffffff" cellSpacing=0 cellPadding=0 border=1><TBODY><TR style="HEIGHT: 17px"><TD style="FONT-WEIGHT: bold; TEXT-ALIGN: center">6</TD><TD style="FONT-WEIGHT: bold; TEXT-ALIGN: center">6</TD><TD style="FONT-WEIGHT: bold; TEXT-ALIGN: center">7</TD><TD style="FONT-WEIGHT: bold; TEXT-ALIGN: center">4</TD><TD style="FONT-WEIGHT: bold; TEXT-ALIGN: center">7</TD><TD style="FONT-WEIGHT: bold; TEXT-ALIGN: center">8</TD></TR></TBODY></TABLE>

 

[facethegod]

Thanks facethegod it works perfect but i do not want thier counts to be number store as text

<TABLE style="PADDING-RIGHT: 2pt; PADDING-LEFT: 2pt; FONT-SIZE: 10pt; FONT-FAMILY: Arial,Arial; BACKGROUND-COLOR: #ffffff" cellSpacing=0 cellPadding=0 border=1><TBODY><TR style="HEIGHT: 17px"><TD style="FONT-WEIGHT: bold; TEXT-ALIGN: center">6</TD><TD style="FONT-WEIGHT: bold; TEXT-ALIGN: center">6</TD><TD style="FONT-WEIGHT: bold; TEXT-ALIGN: center">7</TD><TD style="FONT-WEIGHT: bold; TEXT-ALIGN: center">4</TD><TD style="FONT-WEIGHT: bold; TEXT-ALIGN: center">7</TD><TD style="FONT-WEIGHT: bold; TEXT-ALIGN: center">8</TD></TR></TBODY></TABLE>

try...

Option Explicit
Sub tst()
Dim a, b, c() As String, x As Integer, m As Integer, ii As Integer, i As Integer, ac As New Collection, r As Range
With Application
Set r = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    With r
        a = Evaluate("=INDEX(LEFT(" & .Address & ",3),0,1)")
        b = .Value
    End With
For i = 1 To UBound(a, 1)
    On Error Resume Next
    ac.Add a(i, 1), CStr(a(i, 1))
Next
ReDim c(1 To UBound(a, 1), 1 To ac.Count): x = 2
For i = 1 To ac.Count
c(1, i) = ac.Item(i)
    Do Until IsError(.Match(ac.Item(i), a, 0))
        ii = .Match(ac.Item(i), a, 0): x = x + 1
        c(x, i) = b(ii, 1)
        a(ii, 1) = Empty
    Loop
c(2, i) = x - 2: m = .Max(x, m): x = 2
Next
End With
Range("C1").Resize(m, UBound(c, 2)) = c
    With Range("C2").Resize(1, UBound(c, 2))
    .Value = .Value2
    End With
End Sub

 

[ayazgreat]

Thank you very much facethegod, I have made some addition in these lines.

Range("B1").Resize(m, UBound(c, 2)) = c
With Range("B1").Resize(m, UBound(c, 2))
.HorizontalAlignment = xlCenter
End With
    With Range("B2").Resize(1, UBound(c, 2))
    .Value = .Value2
    .Font.Bold = True
    
    End With

 

[Legacy 68668]

Seiya

Can it be possibel that result of your macro "Numbers Store as Text" of all splited series ?

        With .Resize(1, 1)
            For i = 0 To UBound(x)
                .Offset(, i).Resize(2).Value = _
                Application.Transpose(Array(x(i), UBound(y(i))))
                With .Offset(2, i).Resize(UBound(y(i)))
                    .NumberFormat = "@"
                    .Value = Application.Transpose(y(i))
                End With
            Next
        End With

 

[ayazgreat]

Seiya it does nothing, result is same as previous in your code