• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Code van HSV/Wher loopt vast

  • Onderwerp starter Onderwerp starter jansm
  • Startdatum Startdatum
Status
Niet open voor verdere reacties.

jansm

Gebruiker
Lid geworden
2 apr 2014
Berichten
421
Goedemiddag,
HSV heeft onderstaande code voor mij gemaakt (vraag gepost op dd 4-feb-2016 00:14, code gepost in post #40, laatste bericht 8 feb 2016). Deze code loopt nu vast, melding: Fout 6 tijdens uitvoering, overloop.
Zou de oorzaak kunnen zijn dat er een limiet van aantal regels is bereikt (ca 5000)? Uiteraard is een oplossing van iedereen welkom, niet alleen HSV/Wher.

Private Sub Commandbutton2_Click()
Dim sn, sp, arr, arr2 'delareren van alle variabelen
Dim i As Long, n As Long, j As Long, jj As Long, jjj As Long, jjjj As Long, a As Long 'declaratie
Dim Dic As Object 'idem
Dim id As String 'idem
Dim c As Range 'idem
Dim t As Single 'idem
t = Timer 'spreekt voor zich
Application.ScreenUpdating = False 'tegen flikkeren van het scherm
Set Dic = CreateObject("Scripting.Dictionary") 'dictionary aanmaken om dubbele gegevens tegen te gaan.
sn = Sheets("personen").Cells(1).CurrentRegion 'gooi alle aaneengesloten gegevens in de array "sn".
sp = Sheets("feiten").Cells(1).CurrentRegion ' idem als sn maar dan sp.
ReDim arr(1 To UBound(sn) + UBound(sp), 1 To UBound(sn, 2)) 'maak een array aan met de grootte van 1 tot de rijen van 'sn' + 'sp', en de breedte van de kolommen van 'sn'.
n = UBound(sn) + UBound(sp) 'geef 'n' de waarde van de rijen sn+sp.
For i = UBound(sn) To 1 Step -1 'van onderen naar boven de lus laten lopen.
id = sn(i, 1) & "_" & sn(i, 9) 'maak een id aan van de de gegevens uit de array (doorsnede kolom A en kolom I met de underscore als acheidingsteken).
If Not Dic.Exists(id) Then 'als het niet aanwezig is maak het aan in de volgende regel
Dic(id) = 0
For jj = UBound(sp) To 2 Step -1 'van onderen naar boven de lus laten lopen (laatste cel tot 2)
If sn(i, 1) = sp(jj, 1) And sp(jj, 18) = "ALIAS" Then 'als de rij van kolom A van blad 'personen' gelijk is aan de rij van kolom A van blad 'feiten' en de rij op kolom R = "Alias" dan
n = n - 1 'verlaag dan n minus 1
arr(n, 1) = sp(jj, 1) 'arr(waarde van n,1), wordt de waarde van sp(jj,1)
arr(n, 5) = sp(jj, 19) 'arr(waarde van n,5), wordt de waarde van sp(jj,19)
End If
Next jj
n = n - 1
For j = 1 To UBound(arr, 2) 'een lus van links naar rechts waarmee j steeds ophoogt met 1
arr(n, j) = sn(i, j) 'arr(n,j) krijgt de waarde van sn(i,j)
Next j 'volgende j tot einde
End If
Next i
ReDim arr2(1 To UBound(arr), 1 To UBound(arr, 2)) 'maak een nieuwe array met arr2
aa = UBound(arr) - n 'aa krijgt de waarde door getalletjes van elkaar af te trekken
n = 0

For jjj = UBound(arr) - aa To UBound(arr) 'nieuwe lus jjj
n = n + 1 'spreekt voor zich nu (elke keer dat j wordt verhoogt, wordt n een groter getal).
For jjjj = 1 To UBound(arr, 2) 'moet je nu wel weten
nn = nn + 1
arr2(n, nn) = arr(jjj, jjjj) 'arr2(n,nn) krijgt de waarde van arr(jjj,jjjj)
Next jjjj 'volgende jjjj
nn = 0 'maak n weer nul
Next jjj 'volgende jjj
With Sheets("PERS+FEITEN") 'alles met een punt voor elk stukje code heeft betrekking op blad "test".
.Cells(1).CurrentRegion.Clear

.Cells(1).Resize(UBound(arr2), UBound(arr2, 2)) = arr2 'alle gegevens van de array arr2 worden weggeschreven (rijen en kolommen)
On Error Resume Next 'om geen foutmelding in de code te krijgen in volgende regelcode als er geen lege cellen zijn
'.Columns(3).SpecialCells(4).Offset(, -2).Font.Color = vbRed 'voor alle lege cellen in kolom C en dan twee kolommen naar links die tekstkleur blauw maken
.Columns(3).SpecialCells(4).Offset(, 2).SpecialCells(2).Interior.Color = vbGreen ' 6750105
End With 'einde met betrekking op tabblad 'test'.
Cells.Select
With Selection.Font
.Name = "Calibri"
.Size = 8
End With
Selection.Columns.AutoFit
Debug.Print Format(Timer - t, "0.0000"), "hsv 2" 'ga voor deze coderegel naar Menu Beeld > Venster direct om de snelheid uit te lezen. KAN WEG!!!
Set Odic = Nothing 'de boel weer opruimen
Application.ScreenUpdating = True 'mag ook weggelaten worden trouwens (na afloop code keert scherm automatisch terug
Range("A1").Select
Selection.End(xlDown).Select
End Sub 'einde verhaal
 
De sheet "personen" bestaat niet?
De cel A1 in de sheet personen is leeg?
Aan de limiet van 5000regels ligt het niet, dat mag zeker tot 65000.
Met een voorbeeld bestandje met deze code wordt je sneller en beter geholpen.
 
Alphamax, voorbeeld bestand in posting die ik aangeef. Ben nu niet instaat om het hier opnieuw te plaatsen. In dit bestand tabblad 'test', knop hsv2. De code die ik hierboven geplaatst heb heeft altijd in mijn bestand gewerkt. Nu ik het aantal regels heb uitgebreid met ca 500 loopt hij vast met gemelde fout
 
.... Kan dus niet aan aantal regels liggen (nu ca 5000).
 
Heb uw bestand uitgebreidt tot +-51000 rijen en zie hier de tijden:
8,3750 WHER1
0,1719 WHER2
0,0469 hsv 1
0,0469 hsv 2
 
Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan