Excel VBA - Копирование разделенных строк ячейки в новый лист

Question

С кодом, приведенным ниже, который я получил от https://stackoverflow.com/a/41558057/7282657. Я могу разделить, скопировать и вставить данные для строк «Настройка» и нечетных строк микрофона. У меня теперь возникают проблемы с расщеплением и копированием данных для всех микрофонных рядов и их распределения для исправления «комнаты».

По моему мнению, причина, по которой не все данные микрофона разделены, из-за этой строки кода 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 

Здесь также ссылка на образец документа моих данных: 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