Sort and spilit into column from one cell

[parscon]

Hello Friends , It is about 4 days i am trying to find a solution but really cannot and need your help ,I need to sort data into cell and split them into column for example i have these data in one cell and they are ORM - SGL -BRC

i have more than 45000 row and as this reason need VBA that can do this for me .

Really appreciate for your help and try .

A1


30|ORM|10|ORM|3|ORM|3|ORM|2|ORM|25|ORM|15|ORM|10|ORM|5|ORM|10|SGL|15|ORM|20 |ORM|20|ORM|10|ORM|5|ORM|15|ORM|5|ORM|20|ORM|5|ORM|2|SGL|40|ORM|20|ORM|3|OR M|5|ORM|5|ORM|5|ORM|20|BRC|7|ORM|20|ORM|20|ORM|15|ORM|40|SGL|20|ORM

i want the below result

in A2


30|ORM|10|ORM|3|ORM|3|ORM|2|ORM|25|ORM|15|ORM|10|ORM|5|ORM|15|ORM|20|ORM|20 |ORM|10|ORM|5|ORM|15|ORM|5|ORM|20|ORM|5|ORM|40|ORM|20|ORM|3|ORM|5|ORM|5|BRC |5|ORM|5|ORM|20|BRC|7|ORM|20|ORM|20|ORM|15|ORM|20|ORM

A3


10|SGL|2|SGL|40|SGL|

A4


5|BRC|

[JKwan]

give this a go

Sub blah()
Dim ary As Variant
Dim lRow As Long
Dim Index As Long
Dim LastRow As Long
Dim WS As Worksheet
Dim sORM As String
Dim sSGL As String
Dim sBRC As String

Set WS = ThisWorkbook.Worksheets("Sheet1")
LastRow = FindLastRow(WS, "A")
For lRow = 1 To LastRow
sORM = ""
sSGL = ""
sBRC = ""
ary = Split(Cells(1, "A"), "|")
For Index = 0 To UBound(ary) Step 2
Select Case ary(Index + 1)
Case Is = "ORM"
sORM = sORM & ary(Index) & "|" & ary(Index + 1) & "|"

Case Is = "SGL"
sSGL = sSGL & ary(Index) & "|" & ary(Index + 1) & "|"

Case Is = "BRC"
sBRC = sBRC & ary(Index) & "|" & ary(Index + 1) & "|"

End Select
Next Index
WS.Cells(lRow, "B") = Left(sORM, Len(sORM) - 1)
WS.Cells(lRow, "C") = Left(sSGL, Len(sSGL) - 1)
WS.Cells(lRow, "D") = Left(sBRC, Len(sBRC) - 1)
Next lRow
Set WS = Nothing
End Sub
Function FindLastRow(ByVal WS As Worksheet, ColumnLetter As String) As Long
FindLastRow = WS.Range(ColumnLetter & Rows.Count).End(xlUp).Row
End Function

[parscon]

Dear JKwan Really appreciate for your great help just i have a problem when run code in my sample . i attached the sample file . There are blank row between row and also in each cells all ORM - SGL -BRC are not available. if only one brand available also place it in A2 ... .
I think if you check the sample you will understand .
Really appreciate for your help again .

[JKwan]

try this updated code:


Sub blah()
Dim ary As Variant
Dim lRow As Long
Dim Index As Long
Dim LastRow As Long
Dim WS As Worksheet
Dim sORM As String
Dim sSGL As String
Dim sBRC As String

Set WS = ThisWorkbook.Worksheets("Sheet1")
LastRow = FindLastRow(WS, "A")
For lRow = 1 To LastRow
sORM = ""
sSGL = ""
sBRC = ""

If Cells(1, "A") <> "" Then
ary = Split(Cells(lRow, "A"), "|")
For Index = 0 To UBound(ary) Step 2
Select Case ary(Index + 1)
Case Is = "ORM"
sORM = sORM & ary(Index) & "|" & ary(Index + 1) & "|"

Case Is = "SGL"
sSGL = sSGL & ary(Index) & "|" & ary(Index + 1) & "|"

Case Is = "BRC"
sBRC = sBRC & ary(Index) & "|" & ary(Index + 1) & "|"

End Select
Next Index
If sORM <> "" Then WS.Cells(lRow, "B") = Left(sORM, Len(sORM) - 1)
If sSGL <> "" Then WS.Cells(lRow, "C") = Left(sSGL, Len(sSGL) - 1)
If sBRC <> "" Then WS.Cells(lRow, "D") = Left(sBRC, Len(sBRC) - 1)
End If
Next lRow
Set WS = Nothing
End Sub

[parscon]

Really you are great and you save me .

[Paul_Hossler]

Maybe ...




Option Explicit

Sub SplitData()
Dim aAll As Variant, aSplit As Variant
Dim aORM() As String, aSGL() As String, aBRC() As String
Dim iAll As Long, iSplit As Long
Dim sORM As String, sSGL As String, sBRC As String

With ActiveSheet
'bring in as Nx1 array
aAll = Application.WorksheetFunction.Transpose(Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Value)

'join number with string
For iAll = LBound(aAll) To UBound(aAll)
aAll(iAll) = Replace(aAll(iAll), "|ORM", Chr(1) & "ORM")
aAll(iAll) = Replace(aAll(iAll), "|SGL", Chr(1) & "SGL")
aAll(iAll) = Replace(aAll(iAll), "|BRC", Chr(1) & "BRC")
Next iAll

'ready output arrays
ReDim aORM(LBound(aAll) To UBound(aAll))
ReDim aSGL(LBound(aAll) To UBound(aAll))
ReDim aBRC(LBound(aAll) To UBound(aAll))
'split data
For iAll = LBound(aAll) To UBound(aAll)
If Len(aAll(iAll)) > 0 Then
sORM = vbNullString
sSGL = vbNullString
sBRC = vbNullString

aSplit = Split(aAll(iAll), "|")

For iSplit = LBound(aSplit) To UBound(aSplit)
Select Case Right(aSplit(iSplit), 3)
Case "ORM"
sORM = sORM & aSplit(iSplit) & "|"
Case "SGL"
sSGL = sSGL & aSplit(iSplit) & "|"
Case "BRC"
sBRC = sBRC & aSplit(iSplit) & "|"
End Select
Next iSplit

If Len(sORM) > 0 Then aORM(iAll) = Replace(sORM, Chr(1), "|")
If Len(sSGL) > 0 Then aSGL(iAll) = Replace(sSGL, Chr(1), "|")
If Len(sBRC) > 0 Then aBRC(iAll) = Replace(sBRC, Chr(1), "|")
End If
Next iAll

'put back
.Cells(1, 2).Resize(UBound(aAll), 1).Value = Application.WorksheetFunction.Transpose(aORM)
.Cells(1, 3).Resize(UBound(aAll), 1).Value = Application.WorksheetFunction.Transpose(aSGL)
.Cells(1, 4).Resize(UBound(aAll), 1).Value = Application.WorksheetFunction.Transpose(aBRC)
End With
End Sub