split multiple semicolon separated values into new rows for multiple columns

thanks! apologies first time posting. Again I appreciate any help that anyone can offer on this one because it's really stumped me.


Thanks again in advance

Hi,

any mistake in row #2 / Col 3 of the Desired Output ?

Hi,

Thanks for the response, yes, that cell should simply read "WATER".

Split rows into same original worksheet or another worksheet ?

original worksheet

Sub SplitColumns()
    Dim SP2$(), SP3$()
                            AR = [A1].CurrentRegion.Value
                            U& = UBound(AR, 2):  If U < 3 Then Exit Sub
    Application.ScreenUpdating = False
                            W& = 1
    For R& = 2 To UBound(AR)
        SP2 = Split(AR(R, 2), ";")
        SP3 = Split(AR(R, 3), ";")
        U3& = UBound(SP3)

        For N& = 0 To UBound(SP2)
                            W = W + 1
            Cells(W, 1).Value = AR(R, 1)
            Cells(W, 2).Value = Trim(SP2(N))
            Cells(W, 3).Value = Trim(SP3(IIf(N > U3, U3, N)))
            If U > 3 Then For C& = 4 To U: Cells(W, C).Value = AR(R, C): Next C
        Next N
    Next R

    R = W - 1

    For C = 1 To U
        With Cells(2, C)
            .Resize(R).NumberFormat = .NumberFormat
        End With
    Next

    Application.ScreenUpdating = True
    End
End Sub

works excellent thank you!!!

apologies I am getting a subscript out of range error when I run the code. Since I have some cases where column 2 will be blank and column 3 populated and vice versa (in any case at least one of those columns will always be populated) I suppose this might be the cause of the error. Is there a quick line or two that might account for this case?

This is the line where I am getting the error:

Cells(W, 3).Value = Trim(SP3(IIf(N > U3, U3, N)))

Sub SplitColumns()
    Dim SP2$(), SP3$()
                            AR = [A1].CurrentRegion.Value
                            U& = UBound(AR, 2):  If U < 3 Then Exit Sub
    Application.ScreenUpdating = False
                            W& = 1
    For R& = 2 To UBound(AR)
        SP2 = Split(AR(R, 2), ";")
        SP3 = Split(AR(R, 3), ";")
        U3& = UBound(SP3)

        For N& = 0 To UBound(SP2)
                            W = W + 1
            Cells(W, 1).Value = AR(R, 1)
            Cells(W, 2).Value = Trim(SP2(N))
            If U3 < 0 Then T$ = "" Else T = Trim(SP3(IIf(N > U3, U3, N)))
            Cells(W, 3).Value = T
            If U > 3 Then For C& = 4 To U: Cells(W, C).Value = AR(R, C): Next C
        Next N
    Next R

    R = W - 1

    For C = 1 To U
        With Cells(2, C)
            .Resize(R).NumberFormat = .NumberFormat
        End With
    Next

    Application.ScreenUpdating = True
    End
End Sub

Code runs without any errors now but I am noticing the only thing it seems to be missing is the case where this is a value in column 3 but not in column 2. In this case the values appear to be missing and are not present in the output. Can we make it so that it still outputs those lines as well? Thanks in advance.

OK but I need a workwook with original worksheet with all possibles cases and another worksheet
as Desired result … Hope to avoid a gas factory code !

cobble-2.xlsm attached! Thank you!

Thank you again, I know this must be a pain, but now I'm getting a type mismatch error at the very beginning on the below line:

 U& = UBound(AR, 2):  If U < 3 Then Exit Sub

I see nothing in this line that can occurs this error, no such error within your last workbook !

And this line is the same than in previous code … Maybe restart Excel, the computer …

Without the same worksheet data …

i restarted excel and now it works, ha! thank you!!

Sub SplitColumns2()
  AR = [A1].CurrentRegion.Resize(, 7).Value                'your data
  With CreateObject("scripting.dictionary")
    For r = 2 To UBound(AR)                                'loop starting 2nd row
      splits1 = Split(AR(r, 2), ";")                       'split col2
      splits2 = Split(AR(r, 3), ";")                       'split col3
      i = WorksheetFunction.Max(0, UBound(splits1), UBound(splits2))  'max possibilities-1
      ReDim arr(1 To 1, 1 To UBound(AR, 2))                'redim output array
      For i1 = 1 To UBound(arr, 2)                         'write constant stuff to array
        Select Case i1
          Case 2, 3                                        'this columns change
          Case 7: arr(1, 7) = CDbl(AR(r, 7))               'convert date to dbl
          Case Else: arr(1, i1) = AR(r, i1)
        End Select
      Next
      For i2 = 0 To i
        If UBound(splits1) = -1 Then arr(1, 2) = Empty Else arr(1, 2) = splits1(WorksheetFunction.Min(UBound(splits1), i2))
        If UBound(splits2) = -1 Then arr(1, 3) = Empty Else arr(1, 3) = splits2(WorksheetFunction.Min(UBound(splits2), i2))
        .Item(.Count) = arr
      Next
    Next
    Range("A12").Resize(.Count, UBound(arr, 2)).Value = Application.Index(.items, 0, 0)  'output your data
  End With
End Sub

Try

Sub test()
    Dim a, b, i As Long, ii As Long, iii As Long, n As Long, x, y
    a = Sheets("raw").Cells(1).CurrentRegion.Value
    ReDim b(1 To 1000, 1 To UBound(a, 2))
    For i = 1 To UBound(a, 1)
        ReDim x(0), y(0)
        If a(i, 2) <> "" Then x = Split(a(i, 2), ";")
        If a(i, 3) <> "" Then y = Split(a(i, 3), ";")
        For ii = 0 To Application.Max(UBound(x), UBound(y))
            n = n + 1
            For iii = 1 To UBound(a, 2)
                If iii = 2 Then
                    If UBound(x) >= ii Then b(n, iii) = Trim$(x(ii))
                ElseIf iii = 3 Then
                    If UBound(y) >= ii Then b(n, iii) = Trim$(y(ii))
                Else
                    b(n, iii) = a(i, iii)
                End If
            Next
        Next
    Next
    Sheets.Add.Cells(1).Resize(n, 7) = b
End Sub

Thank you so much for the help, I am able to execute the data as needed! Thank you all again.