Excel VBA - Geteilte Zellenzeichenketten in ein neues Blatt kopieren

Question

Mit dem Code, den ich unter https://stackoverflow.com/a/41558057/7282657 erhalten habe, kann ich Daten für die "Setup" -Reihen und die ungeraden Mikrofonreihen teilen, kopieren und einfügen. Womit ich jetzt Probleme habe, ist das Teilen und Kopieren der Daten für alle Mikrofonzeilen und das Zuordnen von Daten zum Korrigieren von "Raum".

Zu meinem Verständnis wird der Grund, warum nicht alle Mikrofondaten geteilt werden, wegen dieser Codezeile mic = .Range("B" & i).Offset(2, 0).Value Gibt es eine Alternative zur Verwendung von Offset, damit ich alle Mikrofonreihen teilen kann? Hier

ist ein Bild von meinen Eingangsdatum

Hier ist, was ich die Ausgabe so aussehen möchte

habe ich versucht, den Code zu ändern, so dass eine IF-Anweisung überprüft, was " Raum "ist es und teilt und kopiert dann die Daten für diesen bestimmten Raum in ein neues Blatt, bis es zum nächsten Raum kommt, in dem der Prozess wiederholt wird.

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 

Hier ist auch ein Link zu einem Beispieldokument meiner Daten: https://drive.google.com/file/d/0B07kTPaMi6JndDVJS01HbVVoTDg/view

I Vielen Dank im Voraus für Ihre Hilfe und entschuldigen uns für die lange Frage!

Answer 1

Dies schien ganz gut

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