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|ORM|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