Question

使用我从https://stackoverflow.com/a/41558057/7282657获得的代码，我可以分割，复制和粘贴“设置”行和奇数麦克风行的数据。我现在遇到的问题是拆分和复制所有麦克风行的数据并将它们分配给正确的“房间”。

根据我的理解，为什么不能分割所有麦克风数据的原因是因为这行代码mic = .Range("B" & i).Offset(2, 0).Value 有没有使用Offset的替代方法，所以我可以拆分所有的Microphone行？

这是我输入数据的图片

这就是我希望输出的样子

我试图修改代码，以便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

这里还有一个指向我数据样本文档的链接： https://drive.google.com/file/d/0B07kTPaMi6JndDVJS01HbVVoTDg/view

我提前感谢您的帮助，并为长期问题道歉！

Answer 1

这看起来效果很好

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

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

1 个答案: