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

[jdrmer]

Hallo dames en heren,
deze code zorgt ervoor dat er een rij wordt ingevoegd met de opmaak vd bestaande rij.
kan iemand mij helpen dat als men dubbelklikt een menuutje laat zien met de keuze hoeveel rijen wil je invoegen?
mvg Jan
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)


With Target
If .Column = 4 And .Value = 0 Then
.Offset(1).EntireRow.Insert
Range(.Address, .Offset(1).Address).EntireRow.FillDown
.Offset(1).EntireRow.ClearContents
Cancel = True
End If
End With
End Sub

 

[HSV]

Bv.

With Target
 If .Column = 4 And .Value = 0 Then
   .Offset(1).Resize(Application.InputBox("regels invoegen", "hoeveel", "typ een getal", , , , , 1)).EntireRow.Insert
 End If
 Cancel = True
End With

 

[jdrmer]

Hallo Harry bedankt, de keuze met aantal rijen invoegen werkt, echter de bestaande rij heeft heeft een bepaalde opmaak.
Als ik dus dubbelklik en kies 4 rijen hebben de nieuwe 4 regels niet de opmaak van de eerste rij.
Kan je me hiermee helpen?
mvg Jan

 

[HSV]

Maak even een voorbeeld-bestandje in Excel Jan.
Hier zijn helpers die vernuftig genoeg zijn.

 

[jdrmer]

Oke bedankt Harry, hier een bijlage met file.
Nu werkt het als men dubbelklikt in colum D krijgt men een melding kies aantal rijen dat werkt. Maar ik zou ook graag dat de opmaak (validatie en kleur) wordt meegenomen in de nieuwe ingevoegde rijen.
Is dat mogelijk?
mvg Jan

 

[HSV]

Maak er een tabel van.

 

[jdrmer]

Hallo Harry, ik heb er een tabel van gemaakt echter wordt er 1 rij gekopieerd en de volgende 2 rijen zijn zonder opmaak.
En waar ik dit toepas bestaat uit ca 2500 rijen.
Weet je een andere oplossing voor dit?
mvg Jan

 

[HSV]

Onderstaande beter Jan?

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim getal
With Target
 If .Column = 4 And .Value = 0 Then
   getal = Application.InputBox("regels invoegen", "geef aan hoeveel rijen invoegen", "typ een getal", , , , , 1)
   If Not getal = False Then
     .Offset(1).Resize(getal).EntireRow.Insert xlShiftDown
       Range("d10:h10").Copy .Resize(getal + 1)
    End If
  Cancel = True
 End If
End With
End Sub

 

[jdrmer]

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Uw

Hallo Harry,
slim opgelost en hartelijk dank.

mvg Jan