Excel VBA - Copying Splitted Cell Strings into a new Sheet - vba

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