CODEWITHSUNDEEP
vbaexcel
Jay
Jay

Reputation: 1

Excel VBA: Splitting strings

So I'm really new to VBA and I'm having a couple of problems. The goal is to press a button whilst on sheet one and for text to columns to happen on sheet 2.

So far I have this code (attached below). My main problems are that I can't seem to get it to split horizontally, I also can't seem to incoroprate a button into it.

Any help would be really appreciated!

Thanks

What I currently have:

Option Explicit

Sub splitcells()

    Dim InxSplit As Long
    Dim Splitcell() As String

    Dim RowCrnt As Long

    With Worksheets("sheet1")

        RowCrnt = 1
        Do While True

            If .Cells(RowCrnt, "A").Value = "" Then
                Exit Do
            End If

            Splitcell = Split(.Cells(RowCrnt, "A").Value, "/")
            If UBound(Splitcell) > 0 Then

                .Cells(RowCrnt, "A").Value = Splitcell(0)

                For InxSplit = 1 To UBound(Splitcell)
                    RowCrnt = RowCrnt + 1

                    .Rows(RowCrnt).EntireRow.Insert

                    .Cells(RowCrnt, "A").Value = Splitcell(InxSplit)

                    .Cells(RowCrnt, "B").Value = .Cells(RowCrnt - 1, "B").Value
                Next
            End If

            RowCrnt = RowCrnt + 1

        Loop

    End With

End Sub

Upvotes: 0

Views: 155

Answers (3)

DisplayName
DisplayName

Reputation: 13386

if you want to split column A cells content into columns you may simply go like follows:

Sub SplitCells()
    With Worksheets("Sheet2") ' change "Sheet2" to the actual sheet name where this has to happen
        .Range("A1", .Cells(.Rows.count, 1).End(xlUp)).TextToColumns DataType:=xlDelimited, Other:=True, OtherChar:="/"
    End With
End Sub

and if you want this to happen upon clicking a button in any sheet, just attach that button to this SplitCells() sub

Upvotes: 1

QHarr
QHarr

Reputation: 84455

You say horizontally and text to columns but then go on to describe a row split.

For rows:

If stacking the output in a different worksheet

Option Explicit
Sub splitcells()
    Dim rng As Range, counter As Long, nextRow As Long
    counter = 1
    For Each rng In Intersect(Worksheets("sheet1").Columns("A"), Worksheets("Sheet1").UsedRange)

        If counter = 1 Then
            Worksheets("Sheet2").Range(rng.Address).Resize(UBound(Split(Trim(rng), "/")) + 1, 1) = Application.Transpose(Split(rng, "/"))
            nextRow = UBound(Split(Trim(rng), "/"))

        Else
            Worksheets("Sheet2").Range(rng.Address).Offset(nextRow).Resize(UBound(Split(Trim(rng), "/")) + 1, 1) = Application.Transpose(Split(rng, "/"))
            nextRow = nextRow + UBound(Split(rng, "/"))
        End If

      counter = counter + 1
    Next rng
End Sub

Or

In same sheet (though this simply overwrite existing in column A and extends)

Option Explicit
Public Sub splitcells()
    Dim rng As Range, outputString As String
    With Worksheets("Sheet1")
       If Application.WorksheetFunction.CountIf(Intersect(.Columns("A"), .UsedRange), "*/*") = 0 Then Exit Sub
        For Each rng In Intersect(.Columns("A"), .UsedRange)
            If Not IsEmpty(rng) Then
                outputString = outputString & "/" & rng.Value
            End If
        Next rng
        outputString = Right$(outputString, Len(outputString) - 1)
        .Range("A1").Resize(UBound(Split(outputString, "/")) + 1, 1).Value = Application.Transpose(Split(outputString, "/"))
    End With
End Sub

Had it been text to columns in a different sheet you could have gone:

Option Explicit
Sub splitcells()
    Application.ScreenUpdating = False
    Dim rng As Range

    For Each rng In Intersect(Worksheets("sheet1").Columns("A"), Worksheets("Sheet1").UsedRange)
       On Error Resume Next
        Worksheets("Sheet2").Range(rng.Address).Resize(1, UBound(Split(rng, "/")) + 1) = Split(rng, "/")
        On Error GoTo 0
    Next rng
    Application.ScreenUpdating = True
End Sub

Upvotes: 0

SJR
SJR

Reputation: 23081

If you just have values going down column A you can do it like this. You need to loop backwards as you are inserting rows and you can use the array created by split rather than having to loop through each element.

Sub x()

Dim r As Long, v

For r = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
    v = Split(Cells(r, 1), "/")
    If UBound(v) > 0 Then
        Cells(r, 1).Resize(UBound(v)).Insert shift:=xlDown
        Cells(r, 1).Resize(UBound(v) + 1).Value = Application.Transpose(v)
    End If
Next r

End Sub

Upvotes: 1

Related Questions