Automatisch een rij toevoegen

[jv345]

Ik ben op zoek naar een stukje VBA-code die het volgende uitvoert:
In het actieve werkblad is een invulformulier samengesteld met 10 rijen.
De gebruiker kan de velden invullen.
Indien de gebruiker op de laatste regel is gekomen dient er automatisch een regel toegevoegd te worden. Deze actie dient steeds herhaald te worden totdat de gebruiker geen gegevens meer heeft in te vullen.
De oplossing zit volgens mij in het toevoegen de eerste keer van 2 regels en dan, indien nodig, steeds 1 rij.
Wie heeft voor mij een oplossing?

 

[jv345]

Is deze vraag zo lastig? Gelet op de reacties tot op heden waarschijnlijk wel.
Ondertussen ben ik wel door gegaan om een oplossing te vinden.
Ik heb nu een macro die werkt met een inputbox waarbij gevraagd wordt hoeveel regels er ingevoegd moeten worden.
Via een symbool in kolom A ( dus voor de tabel) wordt de macro geactiveerd.
Probleem hierbij is dat het symbool dan ook meegekopieerd wordt. En dt is dan wel weer afhankelijk van het aantal regels dat ingevoegd moet worden.
Wie wie de oplossing voor dit probleem?

Sub aanvullen()

Dim x As Long
ActiveCell.EntireRow.Select
If vRows = 0 Then
vRows = Application.InputBox(prompt:= _
"Hoeveel regels wil je toevoegen?", Title:="Add Rows", _
Default:=1, Type:=1)
If vRows = False Then Exit Sub
End If

Dim sht As Worksheet, shts() As String, i As Long
i = 0
i = i + 1
Selection.Resize(rowsize:=2).Rows(2).EntireRow. _
Resize(rowsize:=vRows).Insert Shift:=xlDown
Selection.AutoFill Selection.Resize( _
rowsize:=vRows + 1), xlFillDefault
'Selection.Offset(1).Resize(vRows).EntireRow.
'SpecialCells(xlConstants).ClearContents
'ActiveSheet.Shapes("Picture 6").Select
' Selection.Delete

End Sub

 

[jv345]

VBA kennis gezocht voor laatste stukje macro

Ik blijf het maar proberen.
Ik kom wel steeds een stukje verder maar VBA-code is niet mijn ding.
Ik heb de volgende macro (en die werkt):

Sub Aanvullen1()

Dim x As Long
Range("A55").Select
Selection.Offset(-1, 1).EntireRow.Select
If vRows = 0 Then
vRows = Application.InputBox(prompt:= _
"Hoeveel regels wil je toevoegen?", Title:="Toevoegen rijen", _
Default:=1, Type:=1)
If vRows = False Then Exit Sub
End If

Dim sht As Worksheet, shts() As String, i As Long
i = 0
i = i + 1

Selection.Resize(rowsize:=2).Rows(2).EntireRow. _
Resize(rowsize:=vRows).Insert Shift:=xlDown
Selection.AutoFill Selection.Resize( _
rowsize:=vRows + 1), xlFillDefault
Selection.Offset(1).Resize(vRows).EntireRow. _
SpecialCells(xlConstants).ClearContents

Probleem hierbij is dat als de gebruiker voor de tweede keer weer een aamtalregels wil tussenvoegen de macro weer start vanuit cel A55.
De bedoeling is datdit cel A55 + het eerder ingevulde aantal moet zijn.
Wie helpt mij met dit laatste stukje??

 

[Ginger]

Jv345, Nou vooruit.... Omdat je zelf zo goed bezig bent... :thumb:

Plaats deze code...

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim lRegels As Long

    lRegels = Application.InputBox("Hoeveel regels wil je toevoegen?", "Toevoegen regels", 1, , , , , 1)
    If lRegels = 0 Then Exit Sub
    Target.Offset(1).Resize(lRegels).EntireRow.Insert Shift:=xlDown
    Target.Offset(1).Select
    
End Sub

...in de module van je WORKsheet waar je wilt invoegen. Dubbelklik op de regel waaronder je een n aantal regels (minimaal 1) wilt invoegen.

Heb je hier iets aan?

Groet, Leo

 

[jv345]

Leo,

Schitterende oplossing. Je laat een heleboel code weg en toch werkt het.
Een meester aan het werk dus.

Er is alleen nog 1 dingetje niet helemaal juist.
De formules ( w.o vert.zoeken ) van de regels erboven worden niet meegekopieerd.
Het vreemde is dat de datavalidatievelden wel meegenomen worden.
Ik heb al allerlei regels getracht met Autofill.Selection maar het lukt maar niet.

Wat doe ik fout?

 

[jv345]

Hallo,

Na enige uren zoeken / uitproberen en dergelijke geef ik het op.
Ik krijg het niet voor elkaar om de aangevulde rijen inclusief de formules te krijgen.

Had ik nu toch maar wat doorgeleerd.

 

[Withaar]

Is dit wat?

Sub Aanvullen1()

Dim x As Long
' twee regels aangepast
Range("A65536").End(xlUp).Select
Selection.Offset(0, 1).EntireRow.Select

If vRows = 0 Then
vRows = Application.InputBox(prompt:= _
"Hoeveel regels wil je toevoegen?", Title:="Toevoegen rijen", _
Default:=1, Type:=1)
If vRows = False Then Exit Sub
End If

Dim sht As Worksheet, shts() As String, i As Long
i = 0
i = i + 1

Selection.Resize(rowsize:=2).Rows(2).EntireRow. _
Resize(rowsize:=vRows).Insert Shift:=xlDown
Selection.AutoFill Selection.Resize( _
rowsize:=vRows + 1), xlFillDefault
Selection.Offset(1).Resize(vRows).EntireRow. _
SpecialCells(xlConstants).ClearContents
End Sub

Let op:
Om e.a. goed te laten werken moet je bij
Range("A65536").End(xlUp).Select
De A veranderen in de kolom waar je formule met vert.zoeken in staat.

 

[jv345]

Withaar,

Bedankt voor je reactie.
Ik was eerst was sceptisch over je opmerking dat ik de A-kolom moest aanpassen aan de kolom waar de vert.zoeken in stond.
Dit komt omdat ik meerdere kolommen hiervan hebt.
Ik heb de eerste kolom (B) genomen en .......het werkt als een speer.

Om het helemaal mooi te krijgen heb ik het nu gekoppeld aan het dubbelklikken.
Toch nog fijne paasdagen voor mij.

Nogmaals mijn hartelijke dank.
Ik zal de vraag sluiten.

 

[Ginger]

De formules ( w.o vert.zoeken ) van de regels erboven worden niet meegekopieerd

Hmmmm... Die zag ik niet aankomen. Je hebt inmiddels je oplossing al, maar ik zal je dan mijn aanvulling óók nog maar geven.. ('k had 'Paas-verplichtingen' bij de familie, dus vandaar deze late reactie )

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim lRegels As Long
Dim lTargetRegel As Long
    
    lTargetRegel = Target.Row
    
    lRegels = Application.InputBox("Hoeveel regels wil je toevoegen?", "Toevoegen regels", 1, , , , , 1)
    If lRegels = 0 Then Exit Sub
    Target.EntireRow.Copy
    Rows(lTargetRegel + 1 & ":" & lTargetRegel + lRegels).Insert Shift:=xlDown
    Target.Offset(1).Resize(lRegels).EntireRow.SpecialCells(xlCellTypeConstants).ClearContents
    Target.Offset(1).Select
    
End Sub

Groet, Leo