• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Segregate parts a string based on condition

B

bari2jitu

New Member
I want to segregate singles, doubles and triples from a string.

e.g. (2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 - 11 , 12 - 14 , 15 - 16 , 17 , 18 , 19 , 20 , 21 - 22 , 23 - 25 , 26 , 27 , 28 , 29 , 30 , 31 , 32 , 33 , 34 , 35 , 36 , 37 , 38 , 39 , 40)

Result should be

Singles - (2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 ,17 , 18 , 19 , 20 ,26 , 27 , 28 , 29 , 30 , 31 , 32 , 33 , 34 , 35 , 36 , 37 , 38 , 39 , 40)

Doubles - (10 - 11 ,15 - 16 , 21 - 22 )

Triples - (12 - 14 ,23 - 25 )

With below code i get collection of data but how to write in cell??


Code: 
Sub x()

Dim s AsStringDim a()AsStringDim a2()AsStringDim v AsVariantDim colSingles AsNew CollectionDim colDoubles AsNew CollectionDim colTriples AsNew Collection

s ="2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 - 11 , 12 - 14 , 15 - 16 , 17 , 18 , 19 , 20 , 21 - 22 , 23 - 25 , 26 , 27 , 28 , 29 , 30 , 31 , 32 , 33 , 34 , 35 , 36 , 37 , 38 , 39 , 40"
a = Split(s,",")

ForEach v In a

If InStr(1, v,"-")=0Then
colSingles.Add v,CStr(v)Else
a2 = Split(v,"-")If a2(1)- a2(0)=1Then
colDoubles.Add v,CStr(v)Else
colTriples.Add v,CStr(v)EndIfEndIf

Next v


EndSub
 
A demonstration as a beginner starter :​
Code: 
Sub Demo1()
    Dim L&, R$(2, 0)
        V = "2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 - 11 , 12 - 14 , 15 - 16 , 17 , 18 , 19 , 20 , 21 - 22 , 23 - 25 , 26 , 27 , 28 , 29 , 30 , 31 , 32 , 33 , 34 , 35 , 36 , 37 , 38 , 39 , 40"
    For Each W In Split(Replace(V, " ", ""), ",")
              V = Split(W, "-")
        Select Case UBound(V)
               Case 0:    L = 0
               Case 1:    L = V(1) - V(0)
               Case Else: L = 9
        End Select
            If L >= 0 And L < 3 Then R(L, 0) = IIf(R(L, 0) > "", R(L, 0) & ", ", "") & W
    Next
        [B2:B4].Value2 = R
End Sub
Do you like it ? So thanks to click on bottom right Like !​
​
 
Hi Mark,
Thanks for your help.
Now new query is result will be 24 count.

e.g.
Singles - (2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 ,17 , 18 , 19 , 20 ,26 , 27 , 28 , 29 , 30 , 31 , 32 , 33 , 34 , 35 , 36 , 37 , 38 , 39 , 40)

2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 ,17 , 18 , 19 , 20 ,26 , 27 , 28 , 29 , 30 , 31 , 32 , 33 , 34 , 35 , 36 , 37 will be in saperate (cell A10)
38, 39, 40.......(next 24 count should be below the abow result (cell A11)

12-13, 15-16, 21-22, 49-50, 51-52, 55-56, 59-60, 66-67, 74-75, 82-83, 158-159, 161-162, 163-164, 226-227, 228-229, 230-231, 232-233
12-13, 15-16, 21-22, 49-50, 51-52, 55-56, 59-60, 66-67, 74-75, 82-83, 158-159, 161-162 will be in saperate (cell B10)
163-164, 226-227, 228-229, 230-231, 232-233 ......(next 24 count should be below the abow result (cell B11)
like wise cell B10, B11 for doubles and Cell c10 ,c11 ,c13 for triples

.
 
Code: 
Sub Demo2()
    Dim C&, oL(2) As Object, D%, L%, N&, R%, V, W
    For C = 0 To 2
        Set oL(C) = CreateObject("System.Collections.ArrayList")
    Next
        V = "2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 - 11 , 12 - 14 , 15 - 16 , 17 , 18 , 19 , 20 , 21 - 22 , 23 - 25 , 26 , 27 , 28 , 29 , 30 , 31 , 32 , 33 , 34 , 35 , 36 , 37 , 38 , 39 , 40, 49-50, 51-52, 55-56, 59-60, 66-67, 74-75, 82-83, 158-159, 161-162, 163-164, 226-227, 228-229, 230-231, 232-233"
    For Each W In Split(Replace(V, " ", ""), ",")
              V = Split(W, "-")
        Select Case UBound(V)
               Case 0:    C = 0
               Case 1:    C = V(1) - V(0)
               Case Else: C = 9
        End Select
            If C >= 0 And C < 3 Then oL(C).Add W
    Next
    For C = 0 To 2
           N = oL(C).Count
        If N Then
            D = 24 \ (C + 1)
            L = N \ D - (N Mod D > 0)
            ReDim V(1 To L, 0)
        For R = 1 To L
            V(R, 0) = Join(oL(C).GetRange(D * (R - 1), Application.Min(D, N)).ToArray, ", ")
            N = N - D
        Next
            Cells(10, C + 1).Resize(L).Value2 = V
            oL(C).Clear
        End If
    Next
        Erase oL
End Sub
You may Like it !​
​
 
bari2jitu said:
With below code i get collection of data but how to write in cell??
Click to expand...
With collections you have to loop through their members. The following writes results to the sheet in cells A1:B3:

Code: 
Sub x()
Dim s As String
Dim a() As String
Dim a2() As String
Dim v As Variant
Dim colSingles As New Collection
Dim colDoubles As New Collection
Dim colTriples As New Collection

s = "2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 - 11 , 12 - 14 , 15 - 16 , 17 , 18 , 19 , 20 , 21 - 22 , 23 - 25 , 26 , 27 , 28 , 29 , 30 , 31 , 32 , 33 , 34 , 35 , 36 , 37 , 38 , 39 , 40"
a = Split(s, ",")

For Each v In a
  If InStr(1, v, "-") = 0 Then
    colSingles.Add v, CStr(v)
  Else
    a2 = Split(v, "-")
    If a2(1) - a2(0) = 1 Then
      colDoubles.Add v, CStr(v)
    Else
      colTriples.Add v, CStr(v)
    End If
  End If
Next v
'Writing to the sheet:
Range("A1:A3").Value = [{"Singles"; "Doubles"; "Triples"}]

SinglesStr = ""
For Each itm In colSingles
If SinglesStr = "" Then SinglesStr = itm Else SinglesStr = SinglesStr & "," & itm
Next itm
Range("B1") = SinglesStr

SinglesStr = ""
For Each itm In colDoubles
If SinglesStr = "" Then SinglesStr = itm Else SinglesStr = SinglesStr & "," & itm
Next itm
Range("B2") = SinglesStr

SinglesStr = ""
For Each itm In colTriples
If SinglesStr = "" Then SinglesStr = itm Else SinglesStr = SinglesStr & "," & itm
Next itm
Range("B3") = SinglesStr

End Sub
If you use dictionaries instead you can write to the sheet/assign to a variable without looping:
Code: 
Sub x2()
Dim s As String
Dim a() As String
Dim a2() As String
Dim v As Variant
Dim colSingles As Object
Dim colDoubles As Object
Dim colTriples As Object
Set colSingles = CreateObject("scripting.dictionary")
Set colDoubles = CreateObject("scripting.dictionary")
Set colTriples = CreateObject("scripting.dictionary")
Dim idxSingle As Long, idxDouble As Long, idxTriple As Long

s = "2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 - 11 , 12 - 14 , 15 - 16 , 17 , 18 , 19 , 20 , 21 - 22 , 23 - 25 , 26 , 27 , 28 , 29 , 30 , 31 , 32 , 33 , 34 , 35 , 36 , 37 , 38 , 39 , 40"
a = Split(s, ",")

For Each v In a
  If InStr(1, v, "-") = 0 Then
    colSingles.Item(idxSingle) = v
    idxSingle = idxSingle + 1
  Else
    a2 = Split(v, "-")
    If a2(1) - a2(0) = 1 Then
      colDoubles.Item(idxDouble) = v
      idxDouble = idxDouble + 1
    Else
      colTriples.Item(idxTriple) = v
      idxTriple = idxTriple + 1
    End If
  End If
Next v

'Writing to the sheet:
Range("A1:A3").Value = [{"Singles"; "Doubles"; "Triples"}]
'This bit puts each result in single cell:
Range("B1").Value = Join(colSingles.items, ",")
Range("B2").Value = Join(colDoubles.items, ",")
Range("B3").Value = Join(colTriples.items, ",")
'This bit puts them in as many cells as are needed:
'Range("B1").Resize(, colSingles.Count).Value = colSingles.items
'Range("B2").Resize(, colDoubles.Count).Value = colDoubles.items
'Range("B3").Resize(, colTriples.Count).Value = colTriples.items
End Sub
 
Hi:

If you are interested in power query solution.

Thanks
 

Attachments

  • Test.xlsx
    95.1 KB · Views: 2
Marc L said:
Code: 
Sub Demo2()
    Dim C&, oL(2) As Object, D%, L%, N&, R%, V, W
    For C = 0 To 2
        Set oL(C) = CreateObject("System.Collections.ArrayList")
    Next
        V = "2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 - 11 , 12 - 14 , 15 - 16 , 17 , 18 , 19 , 20 , 21 - 22 , 23 - 25 , 26 , 27 , 28 , 29 , 30 , 31 , 32 , 33 , 34 , 35 , 36 , 37 , 38 , 39 , 40, 49-50, 51-52, 55-56, 59-60, 66-67, 74-75, 82-83, 158-159, 161-162, 163-164, 226-227, 228-229, 230-231, 232-233"
    For Each W In Split(Replace(V, " ", ""), ",")
              V = Split(W, "-")
        Select Case UBound(V)
               Case 0:    C = 0
               Case 1:    C = V(1) - V(0)
               Case Else: C = 9
        End Select
            If C >= 0 And C < 3 Then oL(C).Add W
    Next
    For C = 0 To 2
           N = oL(C).Count
        If N Then
            D = 24 \ (C + 1)
            L = N \ D - (N Mod D > 0)
            ReDim V(1 To L, 0)
        For R = 1 To L
            V(R, 0) = Join(oL(C).GetRange(D * (R - 1), Application.Min(D, N)).ToArray, ", ")
            N = N - D
        Next
            Cells(10, C + 1).Resize(L).Value2 = V
            oL(C).Clear
        End If
    Next
        Erase oL
End Sub
You may Like it !​
​
Click to expand...

Hi Mark, With your support I made what i exactly required.....Thanks for extreme support
 

Attachments

  • JbariPrintWorkOrders.xlsm
    28.7 KB · Views: 2
According to your attachment :​
Code: 
Sub Demo2a()
    Dim C&, oL(2) As Object, D%, L%, N&, R%, V, W
    For C = 0 To 2
        Set oL(C) = CreateObject("System.Collections.ArrayList")
    Next
        [A3].CurrentRegion.Offset(1).ClearContents
    For Each W In Split(Replace([D1].Value2, " ", ""), ",")
              V = Split(W, "-")
        Select Case UBound(V)
               Case 0:    C = 0
               Case 1:    C = V(1) - V(0)
               Case Else: C = 9
        End Select
            If C >= 0 And C < 3 Then oL(C).Add W
    Next
    For C = 0 To 2
           N = oL(C).Count
        If N Then
            D = 24 \ (C + 1)
            L = N \ D - (N Mod D > 0)
            ReDim V(1 To L, 0)
        For R = 1 To L
            V(R, 0) = Join(oL(C).GetRange(D * (R - 1), Application.Min(D, N)).ToArray, ", ")
            N = N - D
        Next
            Cells(4, C + 1).Resize(L).Value2 = V
            oL(C).Clear
        End If
    Next
        Erase oL
End Sub
 
You must log in or register to reply here.
Back
Top