VBA kopieren x (variabel) Zeilen zu einem anderen Arbeitsblatt

Question

Gods von VBA,

Haben den ganzen Morgen versucht, dieses Stück Amateur-VBA zu optimieren (in diesem Fall bin ich der Amateur) auszuführen, wie ich will .

Was ist jetzt ist das Folgende; Sucht nach Zellwert 1 in Spalte O auf dem dritten Blatt in meiner Arbeitsmappe. Wenn es einen Treffer erhält, kopiert es die Zeile, die 1 in Spalte O hat, in ein neues Arbeitsblatt namens "Blad1". Dann geht es zurück zu meinem 3. Blatt im Arbeitsbuch "Doorvoeren".

Es wird eine Schleife und führen Sie die Aufgabe wie gewünscht, nur was ich nicht tun kann, ist Zeilen kopieren basierend auf einer Variablen in Blatt "Doorvoeren". Wenn dieser Wert 5 ist, möchte ich, dass die Zeile mit 1 in Spalte O und die 4 Zeilen darunter kopiert wird. (zum Beispiel).

Können Sie mir bitte die richtige Richtung hier schicken? Versuchen, es zum Laufen zu bringen, aber auch davon zu lernen.

Mein Code ist unten in der Probe hinzugefügt:

Sub testIt() 
Dim r As Long, endRow As Long, pasteRowIndex As Long 

endRow = 500 
pasteRowIndex = 5 

For r = 3 To endRow 

    If Cells(r, Columns("O").Column).Value = 1 Then 
      Rows(r).Select 
      Selection.Copy 
      Sheets("Blad1").Select 
      Rows(pasteRowIndex).Select 
      ActiveSheet.Paste 
      pasteRowIndex = pasteRowIndex + 1 
      Sheets("Doorvoeren").Select 
    End If 
Next r 
End Sub 

EDIT: Vielen Dank für Ihre Antworten, tatsächlich echte Probleme, einen zu finden, die funktioniert. Um es noch einmal zu erklären; Ich brauche diese VBA optimiert in der Art, wie es auf Zelle Q3 aussieht, in Blatt "Doorvoeren", um die Anzahl der zu kopierenden Zeilen zu erhalten. Also, wenn Q3 Zellwert ist; 5, ich will es, um die Reihe mit der Nummer 1 in Spalte O, in Blatt "Doorvoeren", sondern auch die anderen vier Reihen darunter zu kopieren.

Also meine 1 in Spalte O, ist nur eine Markierung, nicht die Anzahl der Zeilen, die ich kopieren möchte. Bitte fragen/sagen Sie mir, wenn ich nicht ganz klar bin.

Answer 1

Hier meine Lösung ist (leicht ammending Code mit Anmerkungen)

Sub testIt() 

'add another variable (called var) 

Dim r As Long, endRow As Long, pasteRowIndex As Long, Var As Long 

endRow = 500 
pasteRowIndex = 5 

For r = 3 To endRow 

    If Cells(r, Columns("O").Column).Value = 1 Then 

'Grab the var number from the Doorvoeren sheet. Var will then determine how many rows need to be copied in each circumstance 

      Sheets("Doorvoeren").Select 
      Var = Cells(r, Columns("Q").Column).Value 

      Rows(r & ":" & r + (Var - 1)).Select 
      Selection.Copy 
      Sheets("Blad1").Select 
      Rows(pasteRowIndex).Select 
      ActiveSheet.Paste 
      pasteRowIndex = pasteRowIndex + Var 
      Sheets("Doorvoeren").Select 

    End If 

Next r 

End Sub 

Answer 2

Es wird empfohlen, wenn Sie die Verwendung von Select und ActiveSheet vermeiden, stattdessen referenzierte Tabellen und Bereiche verwenden.

Option Explicit 

Sub testIt() 

Dim r As Long, endRow As Long, pasteRowIndex As Long 
Dim PasteRow As Long 

With Sheets("Doorvoeren") 
    ' find last row with data in Column "O" in "Doorvoeren" sheet 
    endRow = .Cells(.Rows.Count, "O").End(xlUp).Row 

    For r = 3 To endRow 
     If .Cells(r, "O").Value = 1 Then 
      pasteRowIndex = 1 
     Else 
      If .Cells(r, "O").Value = 5 Then 
       pasteRowIndex = 5 
      End If 
     End If 

     ' find last row with data in Column "O" in "Blad1" sheet 
     PasteRow = Sheets("Blad1").Cells(Sheets("Blad1").Rows.Count, "O").End(xlUp).Row 

     ' copy number of rows from "Doorvoeren" sheet to "Blad1" sheet, paste them on the first empty row in "Blad1" sheet 
     .Range("O" & r).Resize(pasteRowIndex).EntireRow.Copy Destination:=Sheets("Blad1").Range("A" & PasteRow + 1) 
    Next r  
End With 

End Sub 

Answer 3

Ich habe eine leichte Veränderung auf Ihre Erklärung.

'==================================================== 
Sub testIt() 
    Dim r As Long, endRow As Long, pasteRowIndex As Long 
    Dim DestR as Range 
    Dim Rloop as Range 
    dim RowsCounter as Integer 

    endRow = 500 
    pasteRowIndex = 5 
    RowsCounter = 0 

    For Each Rloop in Sheets("Doorvoeren").range("O3:O" & endRow) 
     if Rloop = 1 and RowsCounter=0 then RowsCounter = Rloop.Offset(0, 2) 
     If Rloop = 1 or RowsCounter > 0 Then 

       Set DestR = Sheets("Blad1").range("A" & pasteRowIndex) 
       Rloop.EntireRow.Copy DestR 
       pasteRowIndex = pasteRowIndex + 1 
       RowsCounter = RowsCounter - 1 
     End If 
    Next Rloop 
End Sub 

hoffe, das hilft besser :)