create possible pairs

[modiria50989]

Please help me out.

I have a column like below (location:column B):

M 255129 255173 1 C 347122 348458 1 C 255319 255352 99

M 631064 631067 3 C 631140 631141 6

M 255129 255173 1 M 255173 255207 4 M 255158 255207 1 C 255319 255352 99

<colgroup><col></colgroup><tbody>
</tbody>

.
.
.

I am looking for a code to group all possible M and C pairs like below (optional location: column C):

M 255129 255173 1 C 347122 348458 1
M 255129 255173 1 C 255319 255352 99
M 631064 631067 3 C 631140 631141 6
M 255129 255173 1 C 255319 255352 99
M 255173 255207 4 C 255319 255352 99
M 255158 255207 1 C 255319 255352 99
.
.
.

Thank you!

 

[Roderick_E]

hi, maybe use C as the delimiter and use DATA/Text to Columns?

 

[modiria50989]

the purpose is making pairs in each row, it's OK if you would like to separate them first.

 

[shg]

Sub modiria()
  Dim colM          As Collection
  Dim colC          As Collection
  Dim vM            As Variant
  Dim vC            As Variant

  Dim i             As Long
  Dim j             As Long
  Dim k             As Long
  Dim s             As String
  Dim asOut()       As String
  Dim asInp()       As String

  For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
    s = Replace(Replace(Cells(i, "B").Value2, "M", "|M"), "C", "|C")

    Set colM = New Collection
    Set colC = New Collection
    
    asInp = Split(s, "|")
    For j = 1 To UBound(asInp)
      If Left(asInp(j), 1) = "M" Then
        colM.Add Item:=asInp(j)
      ElseIf Left(asInp(j), 1) = "C" Then
        colC.Add Item:=asInp(j)
      End If
    Next j

    ReDim asOut(1 To colM.Count * colC.Count, 1 To 1)
    k = 0
    For Each vM In colM
      For Each vC In colC
        k = k + 1
        asOut(k, 1) = vM & " " & vC
      Next vC
    Next vM
    Cells(Rows.Count, "C").End(xlUp)(2).Resize(UBound(asOut)).Value2 = asOut
  Next i
  
  Columns("C").AutoFit
End Sub

	B​	C​
1​	​	​
2​	M 255129 255173 1 C 347122 348458 1 C 255319 255352 99	M 255129 255173 1 C 347122 348458 1
3​	M 631064 631067 3 C 631140 631141 6	M 255129 255173 1 C 255319 255352 99
4​	M 255129 255173 1 M 255173 255207 4 M 255158 255207 1 C 255319 255352 99	M 631064 631067 3 C 631140 631141 6
5​		M 255129 255173 1 C 255319 255352 99
6​		M 255173 255207 4 C 255319 255352 99
7​		M 255158 255207 1 C 255319 255352 99

 

[MickG]

A Similar Option :-
Results in column "C"

[COLOR="Navy"]Sub[/COLOR] MG18Sep12
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Sp [COLOR="Navy"]As[/COLOR] Variant, m [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] A [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] B [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nStr [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range("B1", Range("B" & Rows.Count).End(xlUp))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    m = 0: c = 0
    Dn.Value = Replace(Replace(Dn.Value, "M", "#M"), "C", "#C")
        Sp = Split(Dn.Value, "#")
            ReDim ray(1 To UBound(Sp) + 1, 1 To 2)
                [COLOR="Navy"]For[/COLOR] n = 1 To UBound(Sp)
                    [COLOR="Navy"]If[/COLOR] Left(Trim(Sp(n)), 1) = "M" [COLOR="Navy"]Then[/COLOR]
                         m = m + 1
                        ray(m, 1) = Sp(n)
                    [COLOR="Navy"]ElseIf[/COLOR] Left(Trim(Sp(n)), 1) = "C" [COLOR="Navy"]Then[/COLOR]
                        c = c + 1
                        ray(c, 2) = Sp(n)
                    [COLOR="Navy"]End[/COLOR] If
                [COLOR="Navy"]Next[/COLOR] n

    [COLOR="Navy"]For[/COLOR] A = 1 To m
        [COLOR="Navy"]For[/COLOR] B = 1 To c
            nStr = nStr & ray(A, 1) & " " & ray(B, 2) & vbLf
        [COLOR="Navy"]Next[/COLOR] B
    [COLOR="Navy"]Next[/COLOR] A
    Dn.Offset(, 1) = nStr: nStr = ""
    Dn.Value = Replace(Replace(Dn.Value, "#M", "M"), "#C", "C")
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[modiria50989]

SHG, thank you for the code, but i'm getting run time error that it says subscript out of range!

 

[modiria50989]

sgh, thank you for the code, but i'm getting run time error and it says subscript out of range

 

[modiria50989]

MickG, it works, thank you!

 

[MickG]

You're welcome

 

[modiria50989]

MickG, my last question please. The output of your code are cells with multiple lines in them, but I need each cell with only 1 line in it please. I tried to copy paste the result in notepad then paste it back to excel sheet, didn't work.