VBA Split string from cells into distinct list

[rsj88]

Hi,

i need the VBA script for the follow is this is possible:

i have the below table in in Sheet 1Columns A-C

1	red;blue;green	van;car;bike
2	red	car
3	blue;yellow	truck
4	blue;green;pink	van;car;truck;cycle

In Sheet 2 Column A i need a distinct output of column B without the delimiters eg:
Red
blue
yellow
green
pink

In Sheet 2 Column B i need a distinct output of column C without the delimiters eg:
van
car
bike
truck
cycle

 

[Fluff]

How about

Sub rsj()
   Dim Cl As Range
   Dim DicB As Object, DicC As Object
   Dim Itm As Variant
   
   Set DicB = CreateObject("scripting.dictionary")
   Set DicC = CreateObject("scripting.dictionary")
   With Sheets("Sheet1")
      For Each Cl In .Range("B1", .Range("B" & Rows.Count).End(xlUp))
         For Each Itm In Split(Cl.Value, ";")
            DicB(Itm) = Empty
         Next Itm
         For Each Itm In Split(Cl.Offset(, 1).Value, ";")
            DicC(Itm) = Empty
         Next Itm
      Next Cl
   End With
   With Sheets("Sheet2")
      .Range("A2").Resize(DicB.Count).Value = Application.Transpose(DicB.keys)
      .Range("B2").Resize(DicC.Count).Value = Application.Transpose(DicC.keys)
   End With
End Sub

 

[JEC]

Method without dictionary

Sub JEC()
  With Sheets(1)
     ar = Split(Join(Application.Transpose(.Range("A1", .Range("A" & Rows.Count).End(xlUp))), ";"), ";")
     ar2 = Split(Join(Application.Transpose(.Range("B1", .Range("B" & Rows.Count).End(xlUp))), ";"), ";")
  End With
 
  With Sheets(2).Cells(1, 1)
     .Resize(UBound(ar) + 1) = Application.Transpose(ar)
     .Offset(, 1).Resize(UBound(ar2) + 1) = Application.Transpose(ar2)
     .CurrentRegion.Columns(1).RemoveDuplicates 1, 0
     .CurrentRegion.Columns(2).RemoveDuplicates 1, 0
  End With
End Sub

 

[JEC]

Another one

Sub jec2()
 For Each cl In Sheets(1).Cells(1).CurrentRegion.Cells
   For Each it In Split(cl, ";")
      Select Case cl.Column
          Case 1: If InStr(c00, it) = 0 Then c00 = c00 & it & "|"
          Case 2: If InStr(c01, it) = 0 Then c01 = c01 & it & "|"
      End Select
    Next
 Next
 
 With Sheets(2).Cells(1, 1)
    .Resize(UBound(Split(c00, "|")) + 1) = Application.Transpose(Split(c00, "|"))
    .Offset(, 1).Resize(UBound(Split(c01, "|")) + 1) = Application.Transpose(Split(c01, "|"))
 End With
End Sub

 

[rsj88]

Thanks Fluff. the code is perfect.

JEC your code is prefect too too but only does columns A and B (C and D needed) from the first sheet. however can tweak it and will do the exact same thing.

Thanks both!!

 

[Fluff]

Glad we could help & thanks for the feedback.