Excel VBA-将拆分的单元格字符串复制到新工作表中

使用下面我从中获得的代码，我可以拆分、复制和粘贴“设置”行和奇数麦克风行的数据。我现在遇到的问题是拆分和复制所有麦克风行的数据，并将它们分配到正确的“房间”

据我所知，并非所有麦克风数据都被分割的原因是因为这行代码

mic=.Range（“B”&i）.Offset（2，0）.Value

是否有替代使用偏移的方法，以便我可以拆分所有麦克风行

这是我输入数据的图片

下面是我希望输出的样子

我试图修改代码，以便IF语句检查它是什么“房间”，然后将该房间的数据拆分并复制到新的工作表中，直到它到达下一个房间，并在那里重复该过程

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

子样本（）
调暗myArr、设置、麦克风
将ws设置为工作表，将ws输出为工作表
昏暗的Lrow一样长，i一样长，j一样长，rw一样长，col一样长
昏暗的，昏暗的
设置ws=ThisWorkbook.Sheets（“Sheet1”）~~>将其设置为相关工作表
使用此工作簿
“设置wsOutput=.Sheets.Add（在：=.Sheets（.Sheets.Count）之后）”~~~>为输出添加新工作表
设置wsOutput=ThisWorkbook.Sheets（“Sheet2”）
以
rw=3'获取最后一行
对于i=1至Lrow
如果.Cells（i，1）.Value=“Setup”，则
设置=.Range（“B”&i）.Value
麦克风=.Range（“B”和i）.Offset（2，0）.Value
如果Len（设置）>0，则
myArr=设置到阵列（设置）
wsOutput.Cells（rw，1）.Value=“设置”
wsOutput.Cells（rw，3）.Resize（1，3）.Value=arrHeaders'添加标题
单元格（rw，3）。调整大小（1，3）。自动填充_
Destination:=wsOutput.Cells（rw，3）.调整大小（1，UBound（myArr）+1）'填充标题
单元格（rw+1，3）。调整大小（1，UBound（myArr）+1）。Value=myArr'填充数组
wsOutput.Cells（rw+3,1）.Value=“麦克风”
wsOutput.Cells（rw+3,3）.调整大小（1，UBound（arrHeadersMic）+1）.值=arrHeadersMic
如果Len（mic）>0，则
myArr=麦克风阵列（麦克风）
wsOutput.Cells（rw+4,3）.调整大小（1，UBound（myArr）+1）.值=myArr
如果结束
rw=rw+6
如果结束
如果结束
接下来我
以
结束选择
'j=j+8
下一个r
端接头
功能设置阵列（v）
昏暗的MYAr，我
v=替换（v，“：”，“，”）
v=替换（v，“x”，“，”）
SetupToArray=TrimSpace（分割（v，“，”））
端函数
函数微阵列（w）
w=替换（w，“x”，“x”）
MICTORARRAY=TrimSpace（拆分（w）（“”）
端函数
函数空间（arr）
我想我会坚持多久
对于i=LBound（arr）到UBound（arr）
arr（i）=纵倾（arr（i））
接下来我
TrimSpace=arr
端函数

这里还有一个指向我的数据示例文档的链接：

---

我提前感谢你的帮助，并为这个冗长的问题道歉

这似乎很有效

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

子构建报告（）
调暗myArr、设置、麦克风
将ws设置为工作表，将ws输出为工作表
暗Lrow长，i长，j长，rw长，r长
尺寸m与长度相同，MicRow与长度相同，设置行与长度相同
昏暗的，昏暗的
设置ws=ThisWorkbook.Sheets（“Sheet1”）
使用此工作簿
设置wsOutput=ThisWorkbook.Sheets（“Sheet2”）
以
那么rw=2'0
myArr=设置到阵列（设置）
wsOutput.Cells（rw，1）.Value=“设置”
wsOutput.Cells（rw，3）.Resize（1，3）.Value=arrHeaders'添加标题
单元格（rw，3）。调整大小（1，3）。自动填充_
Destination:=wsOutput.Cells（rw，3）.调整大小（1，UBound（myArr）+1）'填充标题
单元格（rw+1，3）。调整大小（1，UBound（myArr）+1）。Value=myArr'填充数组
rw=rw+3
如果结束
'第行开始的麦克风数量未知（i+2）
MicRow=设置行+1
对于m=MicRow至（MicRow+10）
如果ws.Cells（m，1）.Value=“麦克风”，则
mic=ws.Cells（m，2）.值
如果Len（mic）>0，则
wsOutput.Cells（rw，1）.Value=“麦克风”
wsOutput.Cells（rw，3）.调整大小（1，UBound（arrHeadersMic）+1）.值=arrHeadersMic
myArr=麦克风阵列（麦克风）
wsOutput.Cells（rw+1，3）.调整大小（1，UBound（myArr）+1）.值=myArr
rw=rw+3
如果结束
其他的
“话筒末端”的出口
如果结束
下一个m
如果结束
接下来我
端接头
功能设置阵列（v）
昏暗的MYAr，我
v=替换（v，“：”，“，”）
v=替换（v，“x”，“，”）
SetupToArray=TrimSpace（分割（v，“，”））
端函数
函数微阵列（w）
w=替换（w，“x”，“x”）
MICTORARRAY=TrimSpace（拆分（w）（“”）
端函数
函数空间（arr）
我想我会坚持多久
对于i=LBound（arr）到UBound（arr）
arr（i）=纵倾（arr（i））
接下来我
TrimSpace=arr
端函数

您的代码有什么问题？我当前在第39行遇到一个编译错误：select case和first case之间的语句和标签无效。我想知道是否有其他方法可以在不使用一系列if语句的情况下获得所需的输出，因为这将非常繁琐，并且使我的代码非常长。由于没有行号，您介意在注释中键入引发错误的确切行和错误描述吗？当然，我很抱歉，错误发生在代码{'error here，Select Case和first Case If.Cells（i，1）.Value=“Setup”Then}的行上。错误描述在Select Case和first Case之间是语句无效。我已经在我的代码中对此进行了评论，这不是

Select Case

的工作原理-你需要先研究一下。