Hallo,
2 macro,s(Cow en pitufo_speedy) geven een foutmelding als er een datum is ingevoerd die niet op blad2 voorkomt.
Zie geel gearceerde.
Bij een juiste datum zijn ze wel een stuk sneller, als je met je ogen knippert is het gebeurd.
Macro1 geeft geen fout melding, maak alleen blad2 leeg.
Is wel traag, het zijn hooguit 800 rijen, doet daar circa 7 seconden over.
Dat blad2 leeg gemaakt wordt is geen probleem, want dan worden op blad1 met een vervolg macro enkele kolommen niet ingevuld.
En middels een msgbox kan ik dan wel aangeven het juiste bestand te kiezen of de juiste datum in te voeren.
PS Fouten staan wel tussen .
Maar worden niet geel gearceerd.
Frans
Sub Macro1()
Application.ScreenUpdating = False
t = Timer
datum = Blad1.Cells(1, 2)
With Blad2
For I = .Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1 'gelukkig maar 19 rijen !!!!
If .Cells(I, 2) <> datum Then .Rows(I).Delete
Next I
.Select
End With
MsgBox Timer - t
End Sub
''XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Sub cow()
Application.ScreenUpdating = False
datum = CLng(Sheets("blad1").Range("B1").Value)
t = Timer
With Sheets("blad2")
.AutoFilterMode = False
.Rows(1).Insert 'bovenin rij toevoegen
With .Range("B1").Resize(100001) 'de volle 100.000+1 rijen
.Cells(1).Value = "B1" 'kop er in zitten
.NumberFormat = "0" 'getallen ipv datums[color=yellow][/color]
.AutoFilter 1, "<>" & datum 'filter
.SpecialCells(xlVisible).EntireRow.Delete 'alle zichtbare rijen wissen
[color=yellow].NumberFormat = "dd/mm/yyyy" [/color] 'terug naar datumopmaak
End With
End With
MsgBox Timer - t
End Sub
''XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Sub pitufo_speedy()
kopieren
t = Timer
Application.ScreenUpdating = False
datum = Blad1.Cells(1, 2)
With Sheets("blad2")
.Columns(2).Sort key1:=.Cells(1, 2), Header:=xlNo
.Rows(1).Insert
rijen = .Cells(Rows.Count, 2).End(xlUp).Row
juiste = WorksheetFunction.CountIf(.Columns(2), datum)
[color=yellow]eerste_juiste = .Columns(2).Find(what:=datum).Row[/color]
eerste_foute = eerste_juiste + juiste
If eerste_foute < rijen Then
.Rows(eerste_foute & ":" & rijen).Delete
End If
If eerste_foute > 1 Then
.Rows("1:" & eerste_juiste - 1).Delete
End If
End With
MsgBox Timer - t
End Sub