user13836941
New Member
- Joined
- Jan 17, 2017
- Messages
- 5
I am trying to split data in one cell into multiple cells and then copy it into a new page. With the code below which I have obtained from Excel VBA- Split Cell Strings into individual cells and copy cells to new sheet - Stack Overflow 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
Is there an alternative to using Offset so I can split all the Microphone rows?
My apologies for the long post, this is my first time posting. Thank you in advance for your help!
Here is what my input data looks like
This is what I would like my output to look like
This is my code
To my understanding the reason why not all of the Microphone data is being split is because of this line of code
Code:
mic = .Range("B" & i).Offset(2, 0).ValueMy apologies for the long post, this is my first time posting. Thank you in advance for your help!
Here is what my input data looks like
This is what I would like my output to look like
This is my code
Code:
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
