Nieuwe rijen bijvoegen

[wieter]

Ik dacht het verder alleen aan te kunnen. NIET dus!!
Met de knop "Verlopen datums verwijderen" worden dus de rijen met verlopen datums verwijderd.
Maar voor elke verwijderde rij, zou er een nieuwe rij (met formules) moeten bijgekopieerd worden.
Zodat altijd tot aan rij 40 beschikbaar is.
Heel het blad ombouwen naar tabellen is geen optie meer.
Is dit nog mogelijk?

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
For Each cl In Range("D7:D40")
If cl <> "" And cl < Date Then
cl.EntireRow.Delete
'Hier zou een stukje code moeten komen, dat telkens als er een rij verwijderd wordt
'er een nieuwe lege rij met formules bijgekopieerd wordt
'zodat altijd tot rij 40 beschikbaar is voor invullen
End If
Next
Application.ScreenUpdating = True
End Sub

Bekijk bijlage 179280

 

[HSV]

Test het eens wieter.

Sub hsv()
Dim teller As Long
With Sheets("Blad1")
Application.ScreenUpdating = False
   .Unprotect
If .AutoFilterMode Then .AutoFilterMode = False
    .Range("A6:D40").AutoFilter 4, "<" & CLng(Date)
 teller = .AutoFilter.Range.Offset(1).SpecialCells(12).Rows.Count
    .AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    .Range("A7:A40").AutoFilter
    .Range("A40").Resize(teller + 1).EntireRow.Insert
    .Range("A7:D40").Borders.LineStyle = xlContinuous
    .Range("E7:NF40").FormulaR1C1 = "=IF(OR(RC3="""",RC4=""""),"""",IF(AND(R5C>=RC3,R5C<=RC4,RC2=R93C1),1,IF(AND(R5C>=RC3,R5C<=RC4,RC2=R94C1),2,IF(AND(R5C>=RC3,R5C<=RC4,RC2=R95C1),3,""""))))"
    .Range("E7:NF7").AutoFill Range("E7:NF40")
    .Protect
   End With
End Sub

 

[wieter]

Bingo Harry!! Dat is het.
Prachtig denkwerk om via AutoFilter te werken.
Alleen de rode regel (waar de formules gezet worden) gaat zwaar boven mijn petje.
Ik ga het eens proberen te analyseren en te begrijpen.
Hartelijk dank voor je inzet.

Sub hsv()
Dim teller As Long
With Sheets("Blad1")
Application.ScreenUpdating = False
If .AutoFilterMode Then .AutoFilterMode = False
    .Range("A6:D40").AutoFilter 4, "<" & CLng(Date)
 teller = .AutoFilter.Range.Offset(1).SpecialCells(12).Rows.Count
    .AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    .Range("A7:A40").AutoFilter
    .Range("A40").Resize(teller + 1).EntireRow.Insert
    .Range("A7:D40").Borders.LineStyle = xlContinuous
  [COLOR="#FF0000"]  .Range("E7:NF7").FormulaR1C1 = "=IF(OR(RC3="""",RC4=""""),"""",IF(AND(R5C>=RC3,R5C<=RC4,RC2=R93C1),1,IF(AND(R5C>=RC3,R5C<=RC4,RC2=R94C1),2,IF(AND(R5C>=RC3,R5C<=RC4,RC2=R95C1),3,""""))))"[/COLOR]
    .Range("E7:NF7").AutoFill Range("E7:NF40"), 0
   End With
End Sub

 

[HSV]

Hallo wieter,

Ik heb de code nog aangepast op 19:13 uur i.v.m. protect van je blad (ook het bereik is daar wat aangepast), dus de gehele code daar vanaf te halen.
Voor de rode regelcode heb ik een 'add in' als omvormer naar R1C1 formules.

 

[wieter]

Vooreerst respect voor je inzet.
Zou het kunnen dat het bereik ("A640") in onderstaande regel

.Range("A6:D40").AutoFilter 4, "<" & CLng(Date)

Mag vervangen worden door: ("A740")?
Niet dat dit enige invloed heeft op de werking van de code, enkel om ze perfect te hebben.

ps Hoe komt het eigenlijk dat een ":+d" altijd een smily als resultaat geeft

 

[HSV]

Het bereik moet A6: D40 blijven, anders komen de filters in A7: D7, en wordt de eerste regel in de autofilter niet meegenomen.

Dat er een smiley verschijnt zie je alleen op websites, zal wel iets met html code van doen hebben.
, maar ik ben geen kenner.

 

[wieter]

DOM,DOM,DOM!!
Natuurlijk moet de Range op A6 beginnen i.v.m. filtering.
Ik zet de status op "opgelost" na je nog eens te bedanken.

 

[HSV]

Graag gedaan, en succes ermee. :thumb: