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