Excel 2003 Vba "doornummer" is traag

[ROSO]

Beste leden,

Ik gebruik onderstaand vba om te nummeren. Rij 5 Kolom 1 begint met 1 en het nummert door t/m laatste Empty regel. Op zicht werkt het goed maar met ca 400 record duurt het best lang. Kan iemand mij helpen om het sneller te maken.

Private Sub CountRec()

Dim mijnRij As Long
   
        
    If Cells(5, 2) <> "" Or Cells(5, 4) <> "" Then Cells(5, 1).Value = "1"

    For mijnRij = 6 To 65536
            If Cells(mijnRij, 2) <> "" Or Cells(mijnRij, 4) <> "" Then Cells(mijnRij, 1).Value = Cells(mijnRij - 1, 1).Value + 1
          
      Next mijnRij
  
  End Sub

Alvast bedankt

Groeten,

Roso

 

[leofact]

Het volgende zal een stuk schelen:

Private Sub CountRec()

Dim mijnRij As Long
With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With   
        
    If Cells(5, 2) <> "" Or Cells(5, 4) <> "" Then Cells(5, 1).Value = "1"

    For mijnRij = 6 To 65536
            If Cells(mijnRij, 2) <> "" Or Cells(mijnRij, 4) <> "" Then Cells(mijnRij, 1).Value = Cells(mijnRij - 1, 1).Value + 1
          
      Next mijnRij
With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With
  
  End Sub

mvg Leo

 

[E v R]

Is het echt nodig om door te nummeren tot 65536?

 

[leofact]

Mocht dat niet voldoen helpen dan kun je nog automatisch berekenen uitzetten met
.Calculation = xlManual
En weer aanzetten met
.Calculation = xlAutomatic
(beide in de With declaratie)

Meestal is dit niet nodig. screenupdating uit doet al wonderen.

 

[ROSO]

Beste Leo,

Bedankt voor je snelle reactie.

Ook met deze oplossing blijft het traag ?????.

Groeten

Roso

 

[ROSO]

Hallo Eric,

Nee, dat is niet nodig. Lege rijen hoeven geen nummer te hebben.

Groeten

Roso

 

[leofact]

Is het echt nodig om door te nummeren tot 65536?

goede vraag.

 

[E v R]

pas dit stukje "For mijnRij = 6 To 65536" eens als volgt aan:

For mijnRij = 6 To Application.WorksheetFunction.Max(Cells(Rows.Count, 2).End(xlUp).Row, Cells(Rows.Count, 4).End(xlUp).Row, 6)

 

[ROSO]

pas dit stukje "For mijnRij = 6 To 65536" eens als volgt aan:

For mijnRij = 6 To Application.WorksheetFunction.Max(Cells(Rows.Count, 2).End(xlUp).Row, Cells(Rows.Count, 4).End(xlUp).Row, 6)

Hoi Eric,

Ook niet

For mijnRij = 6 To Application.WorksheetFunction.Max(Cells(Rows.Count, 4).End(xlUp).Row, 6)

Ook deze optie te traag

Groeten

Roso:

 

[leofact]

en zo?

Private Sub CountRec()

Dim mijnRij As Integer
Dim iTeller As Integer
With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With
        
    If Cells(5, 2) <> "" Or Cells(5, 4) <> "" Then Cells(5, 1).Value = "1"
        iTeller = 6
            For mijnRij = 6 To Cells.SpecialCells(xlCellTypeLastCell).Row
                If Cells(mijnRij, 2) <> "" Or Cells(mijnRij, 4) <> "" Then
                    Cells(mijnRij, 1) = iTeller
                    iTeller = iTeller + 1
                End If
      Next mijnRij
With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With
End Sub

 

[E v R]

Heb je het geprobeerd in combinatie met de aanvullingen die Leo had gegeven?

Ik gok dat er steeds een event wordt getriggerd wat de boel vertraagd,

even getest met een dikke 400 rijen: 0.078 seconden
staat er voorwardelijke opmaak in kolom A of datavalidaties? Of..?

Plaats anders het bestandje ontdaan van gevoelige info eens

 

[E v R]

en zo?

Leo, nu nummer je door als er een lege regel tussen staat, ROSO's eerste code begint dan steeds weer bij 1,

nog een else toevoegen
Else: iTeller = 1 en de teller laten starten bij 2

 

[leofact]

Leo, nu nummer je door als er een lege regel tussen staat

Bedankt, in mijn eigenwijsheid ging ik er vanuit dat dit de bedoeling was.
Het steeds opnieuw nummeren is natuurlijk wel opzet. De Else is dan de juiste toevoeging.

 

[ROSO]

:d BEDANKT LEO EN ERIC

HET IS GELUKT SCHEELT CA 45 SEC.

:thumb::thumb::thumb:

HARTELIJK DANK EN GROETEN

ROSO

 

[E v R]

Roso, waar lag het dan aan?

Heb nog een andere optie (sneller?) zonder loop:

Sub CountRecNieuw()

    With Range("A5:A" & Application.WorksheetFunction.Max(Cells(Rows.Count, 2).End(xlUp).Row, _
        Cells(Rows.Count, 4).End(xlUp).Row, 6))
        .Formula = "=IF(OR(B5<>"""",D5<>""""),A4+1,0)"
        .Value = .Value
        .Replace What:="0", Replacement:="", LookAt:=xlWhole
    End With

End Sub

 

[ROSO]

Bedankt Eric,

Neem ik ook mee. kan nooit kwaad.

Waar het aan lag weet echter ook niet ik heb de code van Leo gebruikt ca 400 rijen in ca 5 sec.

Private Sub CountRec()

Dim mijnRij As Integer
Dim iTeller As Integer
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlManual 
End With
        
    If Cells(5, 2) <> "" Or Cells(5, 4) <> "" Then Cells(5, 1).Value = "1"
        iTeller = 2
            For mijnRij = 6 To Cells.SpecialCells(xlCellTypeLastCell).Row
                If Cells(mijnRij, 2) <> "" Or Cells(mijnRij, 4) <> "" Then
                    Cells(mijnRij, 1) = iTeller
                    iTeller = iTeller + 1
                   Else
                     iTeller = 1
                End If
      Next mijnRij
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlAutomatic 
End With
End Sub

Nogmaals mijn dank,

Groeten

Roso

 

[cow18]

deze doet 0.2 sec erover

Const rij1     As Long = 6                                 'vanaf deze rij mag je invullen
Const hulpkolom As String = "AA"

Sub CountRec2()
  Dim bereik1, bereik2, c
  t = Timer
  With ActiveSheet
    If .UsedRange.Range("A1").Address <> "$A$1" Then .Range("A1") = " "  'zeker zijn dat usedrange bovenaan links begint
    .AutoFilterMode = False                                'eventuele filter uitzetten
    .UsedRange.Columns(hulpkolom).Formula = "=if(counta(" & .Range("B1").Address(0, 1) & "," & .Range("D1").Address(0, 1) & ")=2,1,0)"
    .UsedRange.Columns(hulpkolom).AutoFilter 1, "1"
    .Range("A1").Resize(rij1 - 1).EntireRow.Hidden = True  'verberg ook die 1e rijen, mogen niet overschreven worden
    With .UsedRange.Columns(1).SpecialCells(xlVisible)
      .FormulaR1C1 = "=R[-1]C+1"                           'zet daar die formule erin
      .Value = .Value                                      'vervang formule door waarden
    End With
    .Range("A1").Resize(rij1 - 1).EntireRow.Hidden = False  'bovenste rijen terug zichtbaar
    .AutoFilterMode = False                                'filter uitzetten
  End With
  MsgBox Timer - t
End Sub

 

[ROSO]

Cow18 jij ook bedankt.

Groeten,

Roso