rijen kopieren

[popipipo]

In Blad1 heb ik verschillende gegevens
Deze moeten gekopieerd worden naar blad 2.
In kolom A staat hoe vaak.

Met 1 regel lukt mij dit.
Maar hoe moet ik dit verder maken om meerdere regels meerdere keren onder elkaar te plaatsen?

 

[HSV]

Hallo Willem,

Sub kopie2()
 Dim j As Integer
    Sheets("Blad2").Rows("6:100").ClearContents
 For Each cl In Range("A5:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    For j = 1 To cl.Value
       Cells(cl.Row, 6).Resize(, 4).Copy
          Sheets("blad2").Range("c65000").End(xlUp).Offset(1).Resize(, 4).PasteSpecial Paste:=xlPasteValues
     Next
   Next
End Sub

 

[Cobbe]

Zie eens of je met deze aanpassing verder geraakt.

Sub kopie()
 Dim i As Integer
 Application.ScreenUpdating = False
        Sheets("Blad2").Rows("6:100").ClearContents
  rij = 5
With Sheets("Blad1")
  For regel = 5 To .Range("A21").End(xlUp).Row
    
    For i = 1 To .Cells(rij, 1)
        .Range(.Cells(rij, 6), .Cells(rij, 9)).Copy
        Sheets("blad2").Range("c65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    Next i
    rij = rij + 1
  Next regel
End With
Application.ScreenUpdating = True
End Sub

Misschien lukt het.

Succes, Cobbe

 

[Warme bakkertje]

Zonder de 'Copy'

Sub kopie2()
 Dim j As Integer
    Sheets("Blad2").Range("C6:F" & Cells(Rows.Count, 3).End(xlUp).Row).ClearContents
    With Sheets("Blad1")
        For Each cl In .Range("A5:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
            For j = 1 To cl.Value
               Sheets("Blad2").Range("C65000").End(xlUp).Offset(1) _
                            .Resize(, 4) = .Cells(cl.Row, 6).Resize(, 4).Value
            Next
        Next
    End With
End Sub

 

[popipipo]

Ze werken alle drie naar behoren.
Ik heb gekozen voor de oplossing van Warme bakkertje

Ik zit alleen nog met 1 probleem.
Het afhandelen van de foutmelding als er in kolom A geen getal in gevuld wordt.
Wil dan graag een message box hebben met de vermelding : "Vul aantal in"

 

[HSV]

Hierbij ben ik er vanuit gegaan dat je kolom C wel invult.

Sub kopie2()
 Dim j As Integer
    Sheets("Blad2").Rows("6:100").ClearContents
     Application.ScreenUpdating = False
 For Each cl In Range("C5:C" & Cells(Rows.Count, 3).End(xlUp).Row)
  If cl.Offset(, -2) = "" Then MsgBox "Vul aantal in ": Exit Sub
    For j = 1 To cl.Offset(, -2).Value
       Sheets("blad2").Range("C65000").End(xlUp).Offset(1).Resize(, 4).Value = Cells(cl.Row, 6).Resize(, 4).Value
        
     Next j
   Next cl
   Application.ScreenUpdating = True
End Sub

 

[Cobbe]

Ik heb de aanpassing gedaan, natuurlijk in mijn codevoorstel.

Sub kopie()
 Dim i As Integer
 Application.ScreenUpdating = False
        Sheets("Blad2").Rows("6:100").ClearContents
  rij = 5
With Sheets("Blad1")
  For regel = 5 To .Range("A21").End(xlUp).Row
        If Cells(rij, 1) = "" Then
        MsgBox ("Aantal invullen in cel " & "A" & rij)
        Exit Sub
    End If
    
    For i = 1 To .Cells(rij, 1)
          .Range(.Cells(rij, 6), .Cells(rij, 9)).Copy
        Sheets("blad2").Range("c65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    Next i
    rij = rij + 1
  Next regel
End With
Application.ScreenUpdating = True
End Sub

Cobbe

 

[popipipo]

@HSV
Werkt niet geheel zoals ik wil
Hij vraagt ook om een aantal als het aantal wel is ingevuld.

@Cobbe

Ik heb de aanpassing gedaan, natuurlijk in mijn codevoorstel.

Een beetje flauwe opmerking als ik duidelijk aangeef voor de oplossing van Warme bakkertje ga.

Extra wrang als je oplossing nog niet eens goed werkt.
Bij niet niet invullen van het aantal verschijnt de messagebox niet eens.

Nog een (misschien overbodige) aanvulling:
Als het aantal niet ingevuld is moet je in 'Blad1' blijven
Is het aantal wel ingevuld dan moet er naar 'Blad2' gegaan worden.

 

[E v R]

Willem, eventueel een kleine aanvulling: (in dit geval op Cobbe's code) met dezelfde aanname als Harry (kolom C wel gevuld),
meteen middels een Inputbox een getal invullen,

dit stukje:

With Sheets("Blad1")
        For regel = 5 To .Cells(.Rows.Count, 3).End(xlUp).Row
            If IsNumeric(.Cells(rij, 1)) = False Or IsEmpty(.Cells(rij, 1)) = True Then
                .Cells(rij, 1) = InputBox("Aantal invullen in cel " & "A" & rij)
            End If

ipv:

With Sheets("Blad1")
  For regel = 5 To .Range("A21").End(xlUp).Row
        If Cells(rij, 1) = "" Then
        MsgBox ("Aantal invullen in cel " & "A" & rij)
        Exit Sub
    End If

 

[E v R]

Suggestie in Rudi's code toegepast:

Sub kopie2()
    Dim j As Integer, cl As Range
    With Sheets("Blad2")
        .Range("C6:F" & Application.WorksheetFunction.Max(.Cells(.Rows.Count, 3).End(xlUp).Row, 6)).ClearContents
    End With
    With Sheets("Blad1")
        For Each cl In .Range("A5:A" & .Cells(Rows.Count, 3).End(xlUp).Row)
            If IsNumeric(cl.Value) = False Or IsEmpty(cl.Value) = True Then
                cl.Value = Application.InputBox("Aantal invullen in cel " & "A" & cl.Row, Type:=1)
                If cl.Value = False Then cl.Value = "": GoTo Gadoor:
            End If
            For j = 1 To cl.Value
                Sheets("Blad2").Range("C65000").End(xlUp).Offset(1) _
                        .Resize(, 4) = .Cells(cl.Row, 6).Resize(, 4).Value
            Next
Gadoor:
        Next
    End With
    With Sheets("Blad2")
        .Select
    End With
End Sub

 

[HSV]

Dan maar even het bestandje erbij Willem.

 

[popipipo]

Dit is mijn (voorlopig?) eindresultaat.

Met dank aan allen.

 

[Warme bakkertje]

Als je tabel op Blad2 leeg is kon het nog mislopen met het wissen. Daarom nog een extra regeltje. Kreeg ook een foutmelding om te switchen naar Blad2 op het einde van de macro.

Sub kopie()
    Dim j As Integer, cl As Range
    [COLOR="red"]With Sheets("Blad2")
        If .[C6] <> "" Then .Range("C6:F" & .Cells(Rows.Count, 3).End(xlUp).Row).ClearContents
   End With[/COLOR]
   With Sheets("Blad1")
        For Each cl In .Range("A5:A" & .Cells(Rows.Count, 3).End(xlUp).Row)
            If IsNumeric(cl.Value) = False Or IsEmpty(cl.Value) = True Then
                cl.Value = InputBox("Aantal invullen voor :" & Chr(10) & Chr(10) & "          Naam : " & Range(("f") & cl.Row) & Chr(10) & "Geb Datum : " & Range(("g") & cl.Row) & Chr(10) & "     Nummer : " & Range(("H") & cl.Row))
            End If
            For j = 1 To cl.Value
                Sheets("Blad2").Range("C65000").End(xlUp).Offset(1).Resize(, 4) = .Cells(cl.Row, 6).Resize(, 4).Value
            Next
        Next
    End With
   [COLOR="red"] Application.Goto [Blad2!A1][/COLOR]
End Sub