• 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.

Bestand loopt vast op code, moet minder zware oplossing

Status
Niet open voor verdere reacties.
G

gl3nn1987

Gebruiker
Lid geworden
24 sep 2010
Berichten
120
Dag allen,

Ik zal het probleem even uitleggen. Ik heb een bestand met daarin 20.000 rijen.
- nu heb ik in de 8ste kolom een code staan zeg voor het gemak even 1t/m 10
- en ik heb in de 5 kolom staan een b/t/m (blij/treurig/middelmatig)

nu heb ik een blad analyse en heb daar 1t/m 10 staan en de voglende code onder activeren worksheet:

Code: 
Private Sub Worksheet_Activate()
Dim c As Range
Dim d As Range
Dim blij As Integer
Dim treurig As Integer
Dim middel As Integer
For Each c In Sheets("Analyse").Range("A2:A" & Sheets("Analyse").Range("A65536").End(xlUp).Row)
    blij = 0
    treurig = 0
    middel = 0
        
    For Each d In Sheets("vastlegging").Range("A2:A" & Sheets("vastlegging").Range("A65536").End(xlUp).Row)
        If d.Offset(, 8) = c Then
            If d.Offset(, 4) = "b" Then
            blij = blij + 1
            ElseIf d.Offset(, 4) = "t" Then
            treurig = treurig + 1
            ElseIf d.Offset(, 4) = "m" Then
            middel = middel + 1
            End If
        End If
    Next
    c.Offset(, 1) = blij
    c.Offset(, 2) = treurig
    c.Offset(, 3) = middel
Next
End Sub


Ik wil dus gewoon de aantallen krijgen van elke status dat ingevoerd is in 1 overzicht, alleen loopt hij op deze code vast door de omvang van de gegevens. Weet iemand een andere code om hetzelfde te doen?
 
Probeer het eens met als eerste opdracht na de Dim statements: Application.ScreenUpdating = False
En als laatste opdracht, dus net na de Next: Application.ScreenUpdating = True
 
Laatst bewerkt:
Ben je bekend met de formule countif / aantal.als ?
 
Ik zou zeggen vervang die Integer eens door Long, zou best eens voldoende kunnen zijn.
 
Allereerste bedankt

snb zei:
Ben je bekend met de formule countif / aantal.als ?
Klik om te vergroten...
in vba nog nooit gebruikt. in excel zelf wel, in dit geval somproduct functie maar daar is alles veel te groot voor loopt het ook op stuk.

Cobbe zei:
Ik zou zeggen vervang die Integer eens door Long, zou best eens voldoende kunnen zijn.
Klik om te vergroten...
Integers vervangen door Longs

edmoor zei:
Probeer het eens met als eerste opdracht na de Dim statements: Application.ScreenUpdating = False
En als laatste opdracht, dus net na de Next: Application.ScreenUpdating = True
Klik om te vergroten...
Screenupdating aan en uit gezet

Beiden werkt niet voldoende. Loopt nog steeds vast.

Me orginele lijst is ook 1t/m9999 om het in dat perspectief even weg te zetten
 
Laatst bewerkt:
Haal die eerste for-next loop eens helemaal weg en zet direct boven de eerste c.Offset de volgende regel:
Set c=Sheets("Analyse").Range("A" & Sheets("Analyse").Range("A65536").End(xlUp).Row)
 
Laatst bewerkt:
Code: 
Dim c As Range
Dim d As Range
Dim blij As Long
Dim treurig As Long
Dim middel As Long
Application.ScreenUpdating = False
    middel = 0
    treurig = 0
    blij = 0
    For Each d In Sheets("vastlegging").Range("A2:A" & Sheets("vastlegging").Range("A65536").End(xlUp).Row)

        If d.Offset(, 8) = c Then
            If d.Offset(, 4) = "b" Then
            blij = blij + 1
            ElseIf d.Offset(, 4) = "t" Then
            treurig = treurig + 1
            ElseIf d.Offset(, 4) = "m" Then
            middel = middel + 1
            End If
        End If
    Next
Set c = Sheets("Analyse").Range("A" & Sheets("Analyse").Range("A65536").End(xlUp).Row)
    c.Offset(, 3) = blij
    c.Offset(, 4) = treurig
    c.Offset(, 5) = middel
Application.ScreenUpdating = True

Dat is wat ik nu heb staan. maar zo vergelijkt hij d met een lege value.
 
Laatst bewerkt:
Klopt jouw if-constructie wel? De gegevens in kolom 5 worden alleen geteld als in kolom 9 een c staat. En c is een range. Ik weet niet hoe je dit bedoelt.
 
Laatst bewerkt:
Je hoeft in dit geval ook helemaal geen VBA te gebruiken, maar alleen de gewone Excelformules.

Plaats je voorbeeldbestand maar eens.
 
rebmog zei:
Klopt jouw if-constructie wel? De gegevens in kolom 5 worden alleen geteld als in kolom 9 een c staat. En c is een range. Ik weet niet hoe je dit bedoelt.
Klik om te vergroten...
Ja die klopt. in kolom 9 staat het id die moet matchen met die op analyse. Dan moet hij in kolom 5 de waardes (4 mogelijke (b/t/m of nog leeg) gaan bepalen en tellen.


Excelformules kan maar op zo groot aantal is dat niet meer aan te raden. Niet vooruit te branden dan. Heb het al geprobeerd ;)

En ondertussen werkt hij wel via long en niet update tot alles gedaan is, alleen dit duurt ook 5min dus vroeg me af of de code nog zodanig geschreven kon worden dat hij nog wat sneller werkt.
 
Je wint al de nodige tijd als je de For ...Next aanpast.

Code: 
For Each d In Sheets("vastlegging").Range("A2:A" & Sheets("vastlegging").Range("A65536").End(xlUp).Row)
... wordt dan ...

Code: 
Dim lRij As Long
lRij = Sheets("vastlegging").Range("A65536").End(xlUp).Row
For Each d In Sheets("vastlegging").Range("A2:A" & lRij)
In de oude situatie werd 20.000 bepaald wat de laatste rij is.
Nu maar 1 keer.

Met vriendelijke groet,


Roncancio
 
Roncancio zei:
Je wint al de nodige tijd als je de For ...Next aanpast.

Code: 
For Each d In Sheets("vastlegging").Range("A2:A" & Sheets("vastlegging").Range("A65536").End(xlUp).Row)
... wordt dan ...

Code: 
Dim lRij As Long
lRij = Sheets("vastlegging").Range("A65536").End(xlUp).Row
For Each d In Sheets("vastlegging").Range("A2:A" & lRij)
In de oude situatie werd 20.000 bepaald wat de laatste rij is.
Nu maar 1 keer.

Met vriendelijke groet,


Roncancio
Klik om te vergroten...

Dank, goede om te onthouden, maar hij trekt het nog steeds niet gewoon. Had net 2014 in de database erbij gedaan. en die 25% extra zorgt ervoor dat ie weer helemaal niks doet...
 
Doe mij een lol en plaats een voorbeeld van die 2 werkbladen.
 
Hij werkt momenteel. Dus hoeft niet, ik kan niet echt elkker een voorbeeld geven want er staan teveel gegevens in van mijn werk, en versimpelen ervan neemt weer alle problemen weg.

Maar in ieder geval allemaal hartelijk bedankt :D
 
Vage vragen, vage antwoorden.

Ik denk dat er nog heel wat aan je werkbladen verbeterd kan worden. Voorbeeldbestanden kunnen daar gigantisch bij helpen.
 
Snb. Ik zal alsnog gaan schonen morgen en je even bestandje toesturen.
 
Het ligt zeker niet aan de code, want een simpel voorbeeldje nagebouwd wat jouw situatie weergeeft en dan doet jouw code er 2 sec over om 21000 rijen te doorzoeken.
De code die ik gemaakt hebt doet er zelfs maar 0.07 sec over.Ik vermoed dat er op blad Vastlegging formules staan ??
Schakel de herberekening eens uit aan het begin v/d code(aan het einde terug inschakelen) en bekijk dan het resultaat eens.

Bij wijze van test.
Probeer de Worksheet_Activate eens en draai daarna mijn code eens en vergelijk de tijden.
Code: 
Private Sub Worksheet_Activate()
t = Timer
Dim c As Range
Dim d As Range
Dim blij As Integer
Dim treurig As Integer
Dim middel As Integer
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
For Each c In Sheets("Analyse").Range("A2:A" & Sheets("Analyse").Range("A65536").End(xlUp).Row)
    For Each d In Sheets("vastlegging").Range("A2:A" & Sheets("vastlegging").Range("A65536").End(xlUp).Row)
        If d.Offset(, 8) = c Then
            Select Case d.Offset(, 4)
                Case Is = "b"
                    blij = blij + 1
                Case Is = "t"
                    treurig = treurig + 1
                Case Is = "m"
                    middel = middel + 1
            End Select
        End If
    Next
    c.Offset(, 1) = blij: blij = 0
    c.Offset(, 2) = treurig: treurig = 0
    c.Offset(, 3) = middel: middel = 0
Next
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
MsgBox Timer - t
End Sub


Sub tst()
t = Timer
Sheets("Analyse").Range("B2").Resize(10, 3).ClearContents
sn = Sheets("Analyse").Range("A2:A" & Sheets("Analyse").Range("A65536").End(xlUp).Row).Resize(, 4)
sn2 = Sheets("vastlegging").Cells(1).CurrentRegion.Offset(1)
For i = 1 To UBound(sn)
    For ii = 1 To UBound(sn2)
        If sn2(ii, 9) = sn(i, 1) Then
            Select Case sn2(ii, 5)
                Case Is = "b"
                    sn(i, 2) = sn(i, 2) + 1
                Case Is = "t"
                    sn(i, 3) = sn(i, 3) + 1
                Case Is = "m"
                    sn(i, 4) = sn(i, 4) + 1
            End Select
        End If
    Next
Next
Sheets("Analyse").Range("A2").Resize(UBound(sn), 4) = sn
MsgBox Timer - t
End Sub
 
Laatst bewerkt:
oei, ik word ouder en trager, ik ben blijven hangen bij reactie 3, die deed het al, dacht ik zo en anders een VBA-varaint ervan
 
Warme bakkertje zei:
Het ligt zeker niet aan de code, want een simpel voorbeeldje nagebouwd wat jouw situatie weergeeft en dan doet jouw code er 2 sec over om 21000 rijen te doorzoeken.
De code die ik gemaakt hebt doet er zelfs maar 0.07 sec over.Ik vermoed dat er op blad Vastlegging formules staan ??
Schakel de herberekening eens uit aan het begin v/d code(aan het einde terug inschakelen) en bekijk dan het resultaat eens.

Bij wijze van test.
Probeer de Worksheet_Activate eens en draai daarna mijn code eens en vergelijk de tijden.
Code: 
Private Sub Worksheet_Activate()
t = Timer
Dim c As Range
Dim d As Range
Dim blij As Integer
Dim treurig As Integer
Dim middel As Integer
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
For Each c In Sheets("Analyse").Range("A2:A" & Sheets("Analyse").Range("A65536").End(xlUp).Row)
    For Each d In Sheets("vastlegging").Range("A2:A" & Sheets("vastlegging").Range("A65536").End(xlUp).Row)
        If d.Offset(, 8) = c Then
            Select Case d.Offset(, 4)
                Case Is = "b"
                    blij = blij + 1
                Case Is = "t"
                    treurig = treurig + 1
                Case Is = "m"
                    middel = middel + 1
            End Select
        End If
    Next
    c.Offset(, 1) = blij: blij = 0
    c.Offset(, 2) = treurig: treurig = 0
    c.Offset(, 3) = middel: middel = 0
Next
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
MsgBox Timer - t
End Sub


Sub tst()
t = Timer
Sheets("Analyse").Range("B2").Resize(10, 3).ClearContents
sn = Sheets("Analyse").Range("A2:A" & Sheets("Analyse").Range("A65536").End(xlUp).Row).Resize(, 4)
sn2 = Sheets("vastlegging").Cells(1).CurrentRegion.Offset(1)
For i = 1 To UBound(sn)
    For ii = 1 To UBound(sn2)
        If sn2(ii, 9) = sn(i, 1) Then
            Select Case sn2(ii, 5)
                Case Is = "b"
                    sn(i, 2) = sn(i, 2) + 1
                Case Is = "t"
                    sn(i, 3) = sn(i, 3) + 1
                Case Is = "m"
                    sn(i, 4) = sn(i, 4) + 1
            End Select
        End If
    Next
Next
Sheets("Analyse").Range("A2").Resize(UBound(sn), 4) = sn
MsgBox Timer - t
End Sub
Klik om te vergroten...

1e manier doet ie 15sec over, 2e manier 1sec. Bizar groot verschil maar ideaal :D
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan