Expand one column to three columns by symbols

[YasserKhalil]

Hello everyone
I have one column with three different signs at the start of each text (the symbols are *, +, -)
Each symbol has to be in one column to look like hierarchy
In the attachment, I put more details

That's my try

Code: Select all

Sub Test()
    Dim a, s As String, i As Long, c As Long, k As Long
    a = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    ReDim b(1 To UBound(a, 1), 1 To 3)
    For i = LBound(a) To UBound(a, 1) + 1
        c = 0
        s = Application.Trim(Application.Clean(a(i, 1)))
        Select Case Left(s, 1)
            Case "*": c = 1
            Case "+": c = 2
            Case "-": c = 3
        End Select
        If c <> 0 Then
            k = k + 1
            b(k, c) = Mid(s, 2)
        End If
    Next i
    Range("M2").Resize(k, UBound(b, 2)).Value = b
End Sub

But I couldn't delete the undesreied rows.

[YasserKhalil]

After some try and error, I could solve it (but of course, I welcome any other solutions)

Code: Select all

Sub Test()
    Dim a, s As String, t As String, i As Long, c As Long, k As Long
    a = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    ReDim b(1 To UBound(a, 1), 1 To 3)
    With Columns("M:O")
        .ClearContents: .Borders.Value = 0
    End With
    For i = LBound(a) To UBound(a, 1)
        c = 0
        s = Application.Trim(Application.Clean(a(i, 1)))
        If i <> UBound(a, 1) Then t = Application.Trim(Application.Clean(a(i + 1, 1)))
        Select Case Left(s, 1)
            Case "*": c = 1
            Case "+": c = 2
            Case "-": c = 3
        End Select
        If c <> 0 Then
            If i <> UBound(a, 1) Then
                If Left(s, 1) = "+" And Left(a(i + 1, 1), 1) = "*" Then GoTo Skipper
            End If
            If i = UBound(a, 1) And Left(s, 1) = "+" Then GoTo Skipper
            k = k + 1
            b(k, c) = Mid(s, 2)
        End If
Skipper:
    Next i
    With Range("M2")
        .Resize(k, UBound(b, 2)).Value = b
        .CurrentRegion.Borders.Value = 1
    End With
End Sub

[Doc.AElstein]

Hi,
I do not understand why you delete a few rows. So I will ignore that for now.

I will assume, for this answer, that the rows to have been deleted have already been deleted. If we assume that, then all the rest can be done in a single code line using that solution way that we have often used of…. “ Do it in a spreadsheet formula, then convert that formula to a VBA Evaluate Range single code line “ ….

This example is ignoring the row deleting.

The final macro , Sub stanciAlanally() has the beautiful one liner, the rest just shows you again how to develop a solution like that

Code: Select all

Sub liminal() '  https://eileenslounge.com/viewtopic.php?f=30&t=37179
' =IF(LEFT(CLEAN(A2);1)="*";MID(CLEAN(A2);2;LEN(CLEAN(A2))-1);"")
 Let Range("Q2").Value = "=IF(LEFT(CLEAN(A2),1)=""*"",MID(CLEAN(A2),2,LEN(CLEAN(A2))-1),"""")"
' =IF(LEFT(CLEAN(A2);1)="+";MID(CLEAN(A2);2;LEN(CLEAN(A2))-1);"")
 Let Range("R2").Value = "=IF(LEFT(CLEAN(A2),1)=""+"",MID(CLEAN(A2),2,LEN(CLEAN(A2))-1),"""")"
' =IF(LEFT(CLEAN(A2);1)="-";MID(CLEAN(A2);2;LEN(CLEAN(A2))-1);"")
 Let Range("S2").Value = "=IF(LEFT(CLEAN(A2),1)=""-"",MID(CLEAN(A2),2,LEN(CLEAN(A2))-1),"""")"
End Sub

Sub standard()
 Let Range("Q2").Value = Evaluate("=IF(LEFT(CLEAN(A2),1)=""*"",MID(CLEAN(A2),2,LEN(CLEAN(A2))-1),"""")")
 Let Range("R2").Value = Evaluate("=IF(LEFT(CLEAN(A2),1)=""+"",MID(CLEAN(A2),2,LEN(CLEAN(A2))-1),"""")")
 Let Range("S2").Value = Evaluate("=IF(LEFT(CLEAN(A2),1)=""-"",MID(CLEAN(A2),2,LEN(CLEAN(A2))-1),"""")")
End Sub

Sub stancial()
 Let Range("Q2:Q19").Value = Evaluate("=IF(LEFT(CLEAN(A2:A19),1)=""*"",MID(CLEAN(A2:A19),2,LEN(CLEAN(A2:A19))-1),"""")")
 Let Range("R2:R19").Value = Evaluate("=IF(LEFT(CLEAN(A2:A19),1)=""+"",MID(CLEAN(A2:A19),2,LEN(CLEAN(A2:A19))-1),"""")")
 Let Range("S2:S19").Value = Evaluate("=IF(LEFT(CLEAN(A2:A19),1)=""-"",MID(CLEAN(A2:A19),2,LEN(CLEAN(A2:A19))-1),"""")")
End Sub

Sub stancially()
Dim Rng As Range: Set Rng = Range("A2:A19")
 Let Range("Q2:Q19").Value = Evaluate("=IF(LEFT(CLEAN(" & Rng.Address & "),1)=""*"",MID(CLEAN(" & Rng.Address & "),2,LEN(CLEAN(" & Rng.Address & "))-1),"""")")
 Let Range("R2:R19").Value = Evaluate("=IF(LEFT(CLEAN(" & Rng.Address & "),1)=""+"",MID(CLEAN(" & Rng.Address & "),2,LEN(CLEAN(" & Rng.Address & "))-1),"""")")
 Let Range("S2:S19").Value = Evaluate("=IF(LEFT(CLEAN(" & Rng.Address & "),1)=""-"",MID(CLEAN(" & Rng.Address & "),2,LEN(CLEAN(" & Rng.Address & "))-1),"""")")
End Sub

Sub normal()
 '    =IF(LEFT(CLEAN(A2:A19);1)={"*","+","-"};MID(CLEAN(A2:A19);2;LEN(CLEAN(A2:A19))-1);"")
' Let Range("Q2:S19").FormulaArray = "=IF(LEFT(CLEAN(RC[-16]:R[17]C[-16]),1)={""*"",""+"",""-""},MID(CLEAN(RC[-16]:R[17]C[-16]),2,LEN(CLEAN(RC[-16]:R[17]C[-16]))-1),"""")"
 Let Range("Q2:S19").FormulaArray = "=IF(LEFT(CLEAN(A2:A19),1)={""*"",""+"",""-""},MID(CLEAN(A2:A19),2,LEN(CLEAN(A2:A19))-1),"""")"
End Sub

Sub stanciAlanally()
Dim Rng As Range: Set Rng = Range("A2:A19")
' =IF(LEFT(CLEAN(A2);1)={"*","+","-"};MID(CLEAN(A2);2;LEN(CLEAN(A2))-1);"")
 Let Range("Q2:S19").Value = Evaluate("=IF(LEFT(CLEAN(" & Rng.Address & "),1)={""*"",""+"",""-""},MID(CLEAN(" & Rng.Address & "),2,LEN(CLEAN(" & Rng.Address & "))-1),"""")")
End Sub

Alan

[YasserKhalil]

Awesome Mr. Alan. Thank you very much for this concise solution.