Excel VBA- Split Cell Strings into individual cells and copy cells to new sheet

Question

I am trying to split cell strings into various cells in one Excel spread sheet and then copy and paste the split cells with new headings into a new sheet. Below is the image of what I am trying to split.

What I am trying to split

Here is what I am trying to achieve. Wanted Outcome .

Unfortunately I am new to stackoverflow so my images wont show. If users do not wish to click the link I will try explain by other means:

I have various cells which contain long strings which I am trying to split. Below is an example of two rows which I would like to split.

  Setup      |  MC 1: 1 x 18 , MC 2: 2 x 23 , MC 3: 2 x 32|
 ------------|----------------------------------------------
  Microphone |  2 x PHILIP DYNAMI SBMCMD                  |

(where | represents a column break)

I would like to split the above with the following headers as shown below.

 Setup     |       |Speaker|Tables|People|Speaker|Tables|People|Speaker|Tables|People| 
 ----------------------------------------------------------------------------------
           |       | MC1   |  1   |  18  | MC2   | 2    | 23   | MC3   | 2    | 32   |
--------------------------------------------------------------------------------------
           |       |       |      |      |       |      |      |       |
---------------------------------------------------------------------------------------
Microphone |       |Number |Manufc| Model|MdlNum |
    ---------------------------------------------------------------------------
           |       |  2    |PHILIP|DYNAMI|SBMCMD |

The following code works for the setup rows. However it does not work for the microphone rows. It manages to split the correct delimiter, however it does not target the correct row containing the Microphone data.

    Sub Sample()

Dim MYAr, setup
Dim MicAr, Mic
Dim ws As Worksheet, wsOutput As Worksheet
Dim Lrow As Long, i As Long, j As Long, rw As Long, col As Long, Rrow As Long

Dim arrHeaders
Dim arrayHeadersMic


Set ws = ThisWorkbook.Sheets("Sheet1") '~~> Set this to the relevant worksheet
'Set wsOutput = ThisWorkbook.Sheets.Add '~~> Add a new worksheet for output
Set wsOutput = ThisWorkbook.Sheets("Sheet2")
rw = 2 '<< output starts on this row
arrHeaders = Array("Speaker", "Tables", "People")
arrHeadersMic = Array("Number", "Manufacturer", "Model", "Model Number")

With ws
    Lrow = .Range("B" & .Rows.Count).End(xlUp).Row '~~> get the last row
    For i = 1 To Lrow
        If .Cells(i, 1).Value = "Setup" Then

            wsOutput.Cells(rw, 1).Value = "Setup"
           wsOutput.Cells(rw + 3, 1).Value = "Microphone"

            setup = .Range("B" & i).Value
            If Len(setup) > 0 Then 'Len Returns an integer containing either the number of characters in a string or the nominal number of bytes required to store a variable.

                MYAr = SetupToArray(setup)
                'add the headers
                wsOutput.Cells(rw, 3).Resize(1, 3).Value = arrHeaders
                wsOutput.Cells(rw + 3, 3).Resize(1, 4).Value = arrHeadersMic

                'fill headers across
                wsOutput.Cells(rw, 3).Resize(1, 3).AutoFill _
                   Destination:=wsOutput.Cells(rw, 3).Resize(1, UBound(MYAr) + 1)
                'populate the array
                wsOutput.Cells(rw + 1, 3).Resize(1, UBound(MYAr) + 1).Value = MYAr

                'figure out the microphone values here....

              Lrow = .Range("B" & .Rows.Count).End(xlUp).Row


                If .Cells(5, 1).Value = "Microphone" Then



                    setup = 0
                    Mic = .Range("B" & i).Value
                    'If Len(Mic) > 0 Then

                    MicAr = MicToArray(Mic)

                        'fill headers across
                        wsOutput.Cells(rw + 3, 3).Resize(1, 4).AutoFill _
                        Destination:=wsOutput.Cells(rw + 3, 3).Resize(1, UBound(MicAr) + 1) 'UBound Returns the highest available subscript for the indicated dimension of an array.

                        'populate the array
                        wsOutput.Cells(rw + 4, 3).Resize(1, UBound(MicAr) + 1).Value = MicAr

                    'End If

               End If



                rw = rw + 7
            End If
        End If
    Next i


End With

End Sub

Function SetupToArray(v)
Dim MYAr, i
v = Replace(v, ":", ",")
v = Replace(v, " x ", ",")
MYAr = Split(v, ",")
'trim spaces...
For i = LBound(MYAr) To UBound(MYAr)
    MYAr(i) = Trim(MYAr(i))
Next i
SetupToArray = MYAr
End Function

Function MicToArray(w)
Dim MicAr, i
w = Replace(w, " x ", " ")
'w = Replace(w, " ", ",")
MicAr = Split(w, " ")



'trimspace
For i = LBound(MicAr) To UBound(MicAr)
    MicAr(i) = Trim(MicAr(i))
Next i
MicToArray = MicAr

End Function

Thank you in advance for your help!

Answer 1

EDIT: updated and tested - works for your "setup" data

Sub Sample()

    Dim MYAr, setup
    Dim ws As Worksheet, wsOutput As Worksheet
    Dim Lrow As Long, i As Long, j As Long, rw As Long, col As Long
    Dim arrHeaders


    Set ws = ThisWorkbook.Sheets("Sheet1") '~~> Set this to the relevant worksheet
    Set wsOutput = ThisWorkbook.Sheets.Add '~~> Add a new worksheet for output
    rw = 2 '<< output starts on this row
    arrHeaders = Array("Speaker", "Tables", "People")

    With ws
        Lrow = .Range("B" & .Rows.Count).End(xlUp).Row '~~> get the last row
        For i = 1 To Lrow
            If .Cells(i, 1).Value = "Setup" Then

                wsOutput.Cells(rw, 1).Value = "Setup"
                wsOutput.Cells(rw + 1, 1).Value = "Microphone"

                setup = .Range("B" & i).Value
                If Len(setup) > 0 Then

                    MYAr = SetupToArray(setup)
                    'add the headers
                    wsOutput.Cells(rw, 3).Resize(1, 3).Value = arrHeaders
                    'fill headers across
                    wsOutput.Cells(rw, 3).Resize(1, 3).AutoFill _
                       Destination:=wsOutput.Cells(rw, 3).Resize(1, UBound(MYAr) + 1)
                    'populate the array
                    wsOutput.Cells(rw + 1, 3).Resize(1, UBound(MYAr) + 1).Value = MYAr

                    'figure out the microphone values here....

                    rw = rw + 6
                End If
            End If
        Next i
    End With

End Sub

Function SetupToArray(v)
    Dim MYAr, i
    v = Replace(v, ":", ",")
    v = Replace(v, " x ", ",")
    MYAr = Split(v, ",")
    'trim spaces...
    For i = LBound(MYAr) To UBound(MYAr)
        MYAr(i) = Trim(MYAr(i))
    Next i
    SetupToArray = MYAr
End Function

Answer 2

Easier to copy the range to the Windows Clipboard and use the TSV Text format (not tested):

Sheet1.Cells.Copy ' copy the range

With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") ' this is late bound MSForms.DataObject
    Dim s As String
    .GetFromClipboard                 ' get the formats from the Windows Clipboard
    s = .GetText                      ' get the "Text" format
    Application.CutCopyMode = False

    ' magic
    s = Replace(s, "MC ", "MC")     ' "MC 1"    to "MC1"
    s = Replace(s, " x ", "|")      ' "1 x 18"  to "1|18"
    s = Replace(s, " , ", "|")      ' "18 , MC" to "18|MC"
    s = Replace(s, ": ", "|")       ' "MC1: 1"  to "MC1|1"
    s = Replace(s, " ", "|")        ' "2|PHILIP DYNAMI SBMCMD" to "2|PHILIP|DYNAMI|SBMCMD"

    ' "more magic"
    s = Replace(s, "Setup" & vbTab, "/Setup||Speaker|Tables|People|Speaker|Tables|People|Speaker|Tables|People/||")
    s = Replace(s, "Microphone" & vbTab, "/Microphone||Number|manufacturer|Model|Model Num/||")
    s = Replace(s, "|", vbTab)        ' cells are separated by tab
    s = Replace(s, "/", vbNewLine)    ' rows are separated by new line

    .SetText s
    .PutInClipboard
End With

Sheet2.PasteSpecial "Text"        ' or Sheet2.Range("A1").PasteSpecial