String Manupulation in VBA

Question

I have single column that needs to be split to multiple, like Text-to-columns in excel. However there is a small challenge. Conventional delimiter will not work. Consider the string below

Original: Domain\Domain Admins Domain2\User Group Domain3\Developers .....(And so on)
Required: Domain\Domain Admins | Domain2\User Group | Domain3\Developers .....(And so on)

The pipe in the required string means that it needs to be split here and copied to next column as per the length of the string.

I have the list in column A with 506 rows. I used following formula to check the occurance of "\" i column B, count ranges from 0-66

=LEN(A2)-LEN(SUBSTITUTE(A2,"\",""))

I need help to code following logic

1. Find "\" in the string
2. Find the Space just before the "\" and split

I used following code but it doesn't serve the purpose

Range("A1:A506").Select
Selection.TextToColumns 

Please help with a code that keeps points 1 and 2 in mind.

Answer 1

This should do it, although I have used different logic to your requirement.

You wanted to find a \ before white space, where as my code simply looks for Domain (note the white space).

Option Explicit

Sub DoThis()

Dim col As Integer
col = 65

Dim splitWord As String
splitWord = "Domain"

Dim row As Integer
row = 1

Do While (Range("A" & row).value <> "")

Dim value As String

value = Range("A" & row).value

Dim values() As String

values = Split(value, " " & splitWord)

Dim firstResult As String

Dim i As Integer

For i = 1 To UBound(values)

firstResult = values(0) ' not efficient but easier code to read

Range(Chr(col + i) & row).value = splitWord & values(i)

Next i

Range(Chr(col) & row).value = firstResult
row = row + 1
col = 65
Loop

End Sub

Before

After

Please note, I updated some of the words slightly to show it's copying the correct data, but it has been tested with your example too.

Before you test it, make sure to create a backup of your data first as macro's like this can't be undone!

Answer 2

Sub ExtractBySlash()

Dim r As Range

Dim subS As Variant

Dim x As Long

Dim y As Long

Dim counter As Long

counter = 1

For Each r In Range("a1:a506")

subS = Split(r.Text, "\")

For x = LBound(subS) + 1 To UBound(subS)

    For y = Len(subS(x)) To 1 Step -1

        If Mid(subS(x), y, 1) = " " Then

            r.Offset(0, counter) = subS(x - 1) & "\" & Left(subS(x), y)

            subS(x) = Trim(Right(subS(x), Len(subS(x)) - y))

            counter = counter + 1

            Exit For

        End If

    Next y

Next x

Next r

End Sub