Split Cells using delimiter(s) to multiple columns in VBA

[Amms123]

Hi, I hope you can help me out, I'm pretty new to VBA coding and the code below works great for Spliting Cells using a single delimiter to multiple columns. However, I was hoping to modify the code so it would allow me to Split Cells using more than delimiter to multiple columns in VBA, such as "," "&" "/" etc. Unfortunately I'm at a loss and would be grateful for any assistance on this problem. Many thanks Amms123

Sub SplitAll()
Dim xRg As Range
Dim xRg1 As Range
Dim xCell As Range
Dim I As Long
Dim xAddress As String
Dim xUpdate As Boolean
Dim xRet As Variant
On Error Resume Next
xAddress = Application.ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select a range", "", xAddress, , , , , 8)
Set xRg = Application.Intersect(xRg, xRg.Worksheet.UsedRange)
If xRg Is Nothing Then Exit Sub
If xRg.Columns.Count > 1 Then
'MsgBox "You can't select multiple columns", , ""
'Exit Sub
End If
Set xRg1 = Application.InputBox("Split to (single cell):", "", , , , , , 8)
Set xRg1 = xRg1.Range("A1")
If xRg1 Is Nothing Then Exit Sub
xUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For Each xCell In xRg
xRet = Split(xCell.Value, "&")
xRg1.Worksheet.Range(xRg1.Offset(I, 0), xRg1.Offset(I + UBound(xRet, 1), 0)) = Application.WorksheetFunction.Transpose(xRet)
Next
Application.ScreenUpdating = xUpdate
End Sub

 

[Rick Rothstein]

Yes, I was selecting a range of columns at one time. However, most of the time the columns would only contain one row of data.

I can change my macro to handle multiple columns, but before I do, just so I know, does my code work for you when you select cells from within one column only?

 

[Amms123]

Yes, it sure does …….

 

[Rick Rothstein]

Yes, it sure does …….

Okay, good. The following macro will process multiple columns (they do not have to be contiguous nor have their rows aligned) placing the output next to each other starting at the specified starting cell...

[table="width: 500"]
[tr]
	[td]Sub SplitAll()
  Dim X As Long, Cnt As Long
  Dim DataRange As Range, OutputCell As Range, Col As Range
  Dim ColAsText As String, Arr As Variant
  Set DataRange = Application.InputBox("Please select a range to process", "Kutools for Excel", Selection.Address, , , , , 8)
  Set OutputCell = Application.InputBox("Split to (single cell):", "Kutools for Excel", , , , , , 8)
  For Each Col In DataRange.Columns
    If Col.Cells.Count = 1 Then
      ColAsText = Col.Value
    Else
      ColAsText = Join(Application.Transpose(Col))
    End If
    For X = 1 To Len(ColAsText)
      If Mid(ColAsText, X, 1) Like "[!A-Z0-9-]" Then Mid(ColAsText, X) = " "
    Next
    ColAsText = Application.Trim(ColAsText)
    Arr = Split(ColAsText)
    OutputCell.Offset(, Cnt).Resize(1 + UBound(Arr)) = Application.Transpose(Arr)
    Cnt = Cnt + 1
  Next
End Sub[/td]
[/tr]
[/table]

 

[Amms123]

I take my hat off to you sir!! Many thanks again.