Excel VBA - Copying Splitted Cell Strings into a new Sheet

Question

With the code below which I have obtained from https://stackoverflow.com/a/41558057/7282657 I can split, copy and paste data for the "Setup" rows and the odd Microphone rows. What I am now having trouble with is splitting and copying the data for all Microphone rows and allocating them to correct "Room".

To my understanding the reason why not all of the Microphone data is being split is because of this line of code mic = .Range("B" & i).Offset(2, 0).Value Is there an alternative to using Offset so I can split all the Microphone rows?

Here is a picture of my input data

Here is what I would like the output to look like

I have tried to modify the code so that an IF statement checks what "Room" it is and then splits and copies the data for that particular Room into a new sheet until it comes to the next Room where the process will be repeated.

Sub Sample()

Dim myArr, setup, mic
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, arrHeadersMic

Set ws = ThisWorkbook.Sheets("Sheet1") '~~> Set this to the relevant worksheet
With ThisWorkbook
   ' Set wsOutput = .Sheets.Add(after:=.Sheets(.Sheets.Count)) '~~> Add a new worksheet for output
    Set wsOutput = ThisWorkbook.Sheets("Sheet2")
End With

rw = 3 '<< output starts on this row

arrHeaders = Array("Speaker", "Tables", "People")
arrHeadersMic = Array("Number", "Manuf", "Model", "ModelNum")

    j = 1
For r = 1 To 1000 ' Do 1000 rows

Select Case Left(Trim(ws.Cells(r, 1).Value), 1000)
Case "Room 1"
ws.Rows(r).Copy wsOutput.Rows(j)

    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

            setup = .Range("B" & i).Value
            mic = .Range("B" & i).Offset(2, 0).Value

            If Len(setup) > 0 Then

                myArr = SetupToArray(setup)

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


                wsOutput.Cells(rw + 3, 1).Value = "Microphone"
                wsOutput.Cells(rw + 3, 3).Resize(1, UBound(arrHeadersMic) + 1).Value = arrHeadersMic

                If Len(mic) > 0 Then

                    myArr = MicToArray(mic)
                    wsOutput.Cells(rw + 4, 3).Resize(1, UBound(myArr) + 1).Value = myArr


                End If

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

End Select


'j = j + 8

Next r
End Sub




Function SetupToArray(v)
Dim MYAr, i
v = Replace(v, ":", ",")
v = Replace(v, " x ", ",")
SetupToArray = TrimSpace(Split(v, ","))
End Function

Function MicToArray(w)
w = Replace(w, " x ", " ")
MicToArray = TrimSpace(Split(w, " "))
End Function

Function TrimSpace(arr)
Dim i As Long
For i = LBound(arr) To UBound(arr)
    arr(i) = Trim(arr(i))
Next i
TrimSpace = arr
End Function

Here is also a link to a sample document of my data: https://drive.google.com/file/d/0B07kTPaMi6JndDVJS01HbVVoTDg/view

I Thank you in advance for your help and apologize for the long question!

Answer 1

This seemed to work quite well

Sub BuildReport()
Dim myArr, setup, mic
Dim ws As Worksheet, wsOutput As Worksheet
Dim Lrow As Long, i As Long, j As Long, rw As Long, r As Long
Dim m As Long, MicRow As Long, SetupRow As Long
Dim arrHeaders, arrHeadersMic

Set ws = ThisWorkbook.Sheets("Sheet1")
With ThisWorkbook
    Set wsOutput = ThisWorkbook.Sheets("Sheet2")
End With

rw = 2 '<< output starts on this row

arrHeaders = Array("Speaker", "Tables", "People")
arrHeadersMic = Array("Number", "Manuf", "Model", "ModelNum")

Lrow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row '~~> get the last row
For i = 1 To Lrow
      If Left(ws.Cells(i, 1).Value, 4) = "Room" Then
      ' Room Info is in Row i. Setup is in Row (i+1).
      wsOutput.Cells(rw, 1).Resize(1, 2).Value = Array(ws.Cells(i, 1).Value, Cells(i, 2).Value)
      rw = rw + 1
      SetupRow = i + 1
      setup = ws.Cells(SetupRow, 2).Value
      If Len(setup) > 0 Then
          myArr = SetupToArray(setup)
          wsOutput.Cells(rw, 1).Value = "Setup"
          wsOutput.Cells(rw, 3).Resize(1, 3).Value = arrHeaders 'add the headers
          wsOutput.Cells(rw, 3).Resize(1, 3).AutoFill _
             Destination:=wsOutput.Cells(rw, 3).Resize(1, UBound(myArr) + 1) 'fill headers across
          wsOutput.Cells(rw + 1, 3).Resize(1, UBound(myArr) + 1).Value = myArr 'populate the array
          rw = rw + 3
      End If

      ' An unknown number of Microphones start in Row (i+2)
      MicRow = SetupRow + 1
      For m = MicRow To (MicRow + 10)
          If ws.Cells(m, 1).Value = "Microphone" Then
              mic = ws.Cells(m, 2).Value
              If Len(mic) > 0 Then
                  wsOutput.Cells(rw, 1).Value = "Microphone"
                  wsOutput.Cells(rw, 3).Resize(1, UBound(arrHeadersMic) + 1).Value = arrHeadersMic
                  myArr = MicToArray(mic)
                  wsOutput.Cells(rw + 1, 3).Resize(1, UBound(myArr) + 1).Value = myArr
                  rw = rw + 3
              End If
          Else
              Exit For ' reached end of Microphones
          End If
      Next m
  End If
Next i

End Sub

Function SetupToArray(v)
Dim MYAr, i
v = Replace(v, ":", ",")
v = Replace(v, " x ", ",")
SetupToArray = TrimSpace(Split(v, ","))
End Function

Function MicToArray(w)
w = Replace(w, " x ", " ")
MicToArray = TrimSpace(Split(w, " "))
End Function

Function TrimSpace(arr)
Dim i As Long
For i = LBound(arr) To UBound(arr)
    arr(i) = Trim(arr(i))
Next i
TrimSpace = arr
End Function