• 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

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 !​
 
With below code i get collection of data but how to write in cell??
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
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 !​

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
 
Back
Top