VBA: Excel crasht door Do while loop

[Rawry]

Hallo Allemaal,

Ik heb een stukje code geschreven om relevante dataregels van één tabblad te kopieren naar een ander tabblad. Wat betreft Excel VBA is mijn kennisniveau nog vrij beperkt.

Wat ik tot nu toe gemaakt heb werkt prima met een For loop. Echter gebruik ik liever een Do While loop. De code moet uiteindelijk per tabblad (12 in totaal) namelijk doorlopen tot regel 999 indien het tabblad helemaal vol staat met data maar ik wil dat de loop stopt wanneer er zo'n 20x achter elkaar door een lege cel geloopt wordt om hem wat sneller en efficienter te maken.

Wanneer ik de For loop vervang door een do While loop gaat het echter mis en blijft Excel hangen. Is er hier sprake van een onbedoelde infinite loop of kan het ook iets anders zijn?
De variabele StopLoop eindigt in mijn testvoorbeeld met For Loop op waarde 76 wanneer ik de For loop tot regel 100 laat doorlopen, dus daar lijkt het niet aan te liggen.

Hieronder het voorbeeld met de Do While loop.

Alvast bedankt voor het meedenken

Groeten,
Rawry

Sub overzichtGenerator()

   
'Deze variabelen geven de rij weer waar data geplakt moet worden (kan efficienter, ik weet het)
Dim PasteRowNumber As Integer
PasteRowNumber = "6"
Dim PasteRowLetter As String
PasteRowLetter = "A"
Dim PasteRow As String
PasteRow = PasteRowLetter & PasteRowNumber


'De Sheet waaruit data gehaald wordt, dit worden er meer
Sheets("Jan").Activate

'De variabelen die bepalen wanneer de loop stopt
Dim SelectionCellRow As Integer
SelectionCellRow = "5"
Dim StopLoop As Integer
StopLoop = "1"

Do While StopLoop < 20 And SelectionCellRow < 99

ActiveSheet.Cells(SelectionCellRow, 4).Select
If ActiveCell = "" Then
    StopLoop = StopLoop + 1
    Else: StopLoop = "1"
End If
If Selection.Value = Sheets("Kaart").Range("A3") Then
    ActiveCell.Offset(, -3).Resize(, 9).Select
    Selection.Copy (Sheets("Kaart").Range(PasteRow))
    PasteRowNumber = PasteRowNumber + 1
    PasteRow = PasteRowLetter & PasteRowNumber
    SelectionCellRow = SelectionCellRow + 1  
End If
Loop

End Sub

 

[emields]

misschien is dit wel iets.

https://www.helpmij.nl/forum/announcement.php?f=5

 

[Rawry]

@emields, dankjewel voor het wijzen op deze info, had de forum etiquette niet goed gelezen. Code tags toegevoegd

 

[cow18]

moeilijk zonder voorbeeld.
Voeg anders voor je loop een msgbox toe en daarin vraag je activecell.row, stoploop en selectioncellrow af.
Misschien weet je dan meer of anders ga je in de debugger en volg je stap per stap je programma.

 

[Rawry]

Dankjewel, voor deze suggestie. Ik heb een MsgBox in de loop opgenomen en het probleem daarmee gevonden:

SelectionCellRow = SelectionCellRow + 1

moet buiten de IF statement staan in plaats van erbinnen. Nu werkt de code weer en heb ik hem helemaal af kunnen krijgen. Bedankt voor de hulp

 

[VenA]

Als je code sneller wilt maken maken kan je beter geen Select en Activate gebruiken. Zonder Do While loop twee snellere varianten die de 12 maanden doorloopt. Als je een voorbeeld plaatst kan het mogelijk nog eenvoudiger/dynamischer.

Sub VenA()
  ar = Application.GetCustomListContents(3)
  For j = 1 To UBound(ar)
    For Each cl In Sheets(ar(j)).Range("D5:D999").SpecialCells(2)
      cl.Offset(, -3).Resize(, 9).Copy Sheets("Kaart").Cells(Rows.Count, 1).End(xlUp).Offset(1)
    Next cl
  Next j
End Sub

Sub VenA1()
  ar = Application.GetCustomListContents(3)
  For j = 1 To UBound(ar)
    With Sheets(ar(j)).Range("A4:I999")
      .AutoFilter 4, "<>"
      .Offset(1).Copy Sheets("Kaart").Cells(Rows.Count, 1).End(xlUp).Offset(1)
      .AutoFilter
    End With
  Next j
End Sub

 

[cow18]

@Rawry,
je declareert PasteRowNumber als integer en iets later stop je daar de waarde 6 als string in. Idem met StopLoop.
Een dubbeltje op zijn kant, dat alles netjes verloopt ... .
Soms is VBA strenger.