macro, aantal rijen invoegen aan de hand van aantal gevulde cellen en gegevens kopier

[arjancuijpers]

Beste,

Ik wil graag in excel.

Op het blad 3 (kavel1) moet er na rij 6 een aantal rijen ingevoegd worden. Het aantal rijen is afhankelijk van het aantal gevulde cellen in kolom A op blad 1 (gegevens).
Na dat de rijen zijn ingevoegd moeten de waarde in kolom A op blad 1 (gegevens) gekopieerd worden naar kolom A van de ingevoegde rijen.

hierbij de file

Met vriendelijke groet,

Arjan

 

[Leotaxi]

probeer deze eens

Sub test_rijinvoegen()
With Sheets("Gegevens")
lr = .Range("A" & Rows.Count).End(xlUp).Row
n = .Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
ReDim test(n)
a = 0
For x = 1 To lr
    If .Range("A" & x) <> vbNullString Then
        test(a) = .Range("A" & x).Value
        a = a + 1
    End If
Next
End With
With Sheets("KAVEL1")
    .Range("A7", "T" & n + 7).Insert shift:=xlDown
    For x = 0 To n
        .Range("A" & x + 8).Value = test(x)
    Next
End With
End Sub

mvg
Leo

 

[arjancuijpers]

probeer deze eens

Sub test_rijinvoegen()
With Sheets("Gegevens")
lr = .Range("A" & Rows.Count).End(xlUp).Row
n = .Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
ReDim test(n)
a = 0
For x = 1 To lr
    If .Range("A" & x) <> vbNullString Then
        test(a) = .Range("A" & x).Value
        a = a + 1
    End If
Next
End With
With Sheets("KAVEL1")
    .Range("A7", "T" & n + 7).Insert shift:=xlDown
    For x = 0 To n
        .Range("A" & x + 8).Value = test(x)
    Next
End With
End Sub

mvg
Leo

Bedankt voor de snelle reactie.
Hij werkt perfect.
Maar ik wil nu de formules overnemen van een rij er boven hoe kan ik dit in deze macro bakken?

mvg

Arjan

 

[Leotaxi]

Dan wordt het zoiets


mvg
Leo

 

[VenA]

De vraag vind ik totaal niet helder. Maak je voor ieder kavel een nieuw bestand aan?

Obv van de code van Leotaxi kom ik tot zoiets. Maar of dit correct is? En dan bedoel ik niet de code maar de uitkomst.

Sub VenA()
Application.ScreenUpdating = False
With Sheets("Gegevens")
    Sheets("KAVEL1").[A7].Resize(.Columns(1).SpecialCells(2).Count, 20).Insert Shift:=xlDown
    With .Range("A1:A" & .Range("A" & Rows.Count).End(xlUp).Row)
        .AutoFilter 1, "<>"
        .Copy Sheets("KAVEL1").[A7]
        .AutoFilter 1
    End With
    With Sheets("KAVEL1")
        .Range("B6:T6").AutoFill Destination:=Range("B6").Resize(Sheets("Gegevens").Columns(1).SpecialCells(2).Count [COLOR="#FF0000"]+ 1[/COLOR], 19)
    End With
End With
End Sub