Vba loopt gedeeltelijk erg traag

perry99 · 9 mrt 2011

Hallo,

Onderstaande VBA doet het echter B1 en B3 zijn erg traag t.o.v. B2.
Als er via B2 een nummer wordt gezocht wordt dat nummer in +/- 0,2 seconden gevonden terwijl als er een nummer van B1 of B3 wordt gezocht duurt dat langer dan 3 seconden.
Het zoekgebied van B1 en B3 is niet groter dan 70 regels, terwijl B2 36000 regels zijn.

Ik hoop dat één van jullie mij hiermee kan helpen, ben er al 2 weken mee bezig en van alles geprobeerd, maar krijg het geen spat sneller.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
 
If Target.Row > 32 And Target.Column = 3 Then
x = Target.Value
    If Len(x) = 6 Then x = "0" & Target.Value
    If Len(x) = 5 Then x = "00" & Target.Value
Set B1 = Worksheets("9 Miljoen").Cells.Find(x, , xlValues, xlWhole)
Set B2 = Workbooks("artikelbestand21.xls").Sheets("DSKNEW_P").Cells.Find(x, , xlValues, xlWhole)
Set B3 = Worksheets("Standaard").Cells.Find(x, , xlValues, xlWhole)
If B1 Is Nothing And B2 Is Nothing And B3 Is Nothing Then MsgBox "Artikelnummer niet gevonden!!!!!!", vbInformation, "Artikelnummer": Exit Sub

If Not B1 Is Nothing Then '9 MILJOEN
        Target.Offset(, 1).ClearContents
        Target.Offset(, 3) = B1.Offset(, 1).Value
        Target.Offset(, 4) = B1.Offset(, 2).Value
        Target.Offset(, 5) = B1.Offset(, 4).Value
        Target.Offset(, 10) = B1.Offset(, 3).Value
        Target.Offset(0, 5).Font.ColorIndex = 1
ElseIf Not B3 Is Nothing Then 'STANDAARD
        Target.Offset(, 1).ClearContents
        Target.Offset(, 3) = B3.Offset(, 1).Value
        Target.Offset(, 4) = B3.Offset(, 2).Value
        Target.Offset(, 5) = B3.Offset(, 3).Value
        Target.Offset(, 5).Font.ColorIndex = 3
        Target.Offset(, 12) = B3.Offset(, 9).Value
        Target.Offset(, 13) = B3.Offset(, 11).Value
Else
       'ARTIKELBESTAND
        Target.Offset(, 1).ClearContents
        Target.Offset(, 3) = B2.Offset(, 1).Value
        Target.Offset(, 4) = B2.Offset(, 2).Value
        Target.Offset(, 5) = B2.Offset(, 5).Value
        Target.Offset(, 5).Font.ColorIndex = 1
        Target.Offset(, 10) = B2.Offset(, 4).Value
        Target.Offset(, 5).Font.ColorIndex = 1
End If
End If

End Sub

Alvast bedankt voor het meedenken.

Groetjes,

Perry

HSV · 9 mrt 2011

Ik weet niet of dit sneller gaat.

Code:

If Not B1 Is Nothing Then '9 MILJOEN
        Target.Offset(, 1).ClearContents
        Target.Offset(, 3).resize( ,2).value = B1.Offset(, 1).resize( ,2).Value
        Target.Offset(, 5) = B1.Offset(, 4).Value
        Target.Offset(, 10) = B1.Offset(, 3).Value
        Target.Offset(0, 5).Font.ColorIndex = 1
ElseIf Not B3 Is Nothing Then 'STANDAARD
        Target.Offset(, 1).ClearContents
        Target.Offset(, 3).resize( , 3).value = B3.Offset(, 1).resize( , 3).Value
        Target.Offset(, 5).Font.ColorIndex = 3
        Target.Offset(, 12) = B3.Offset(, 9).Value
        Target.Offset(, 13) = B3.Offset(, 11).Value
Else
       'ARTIKELBESTAND
        Target.Offset(, 1).ClearContents
        Target.Offset(, 3).resize( ,2).value = B2.Offset(, 1).resize( ,2).Value
        Target.Offset(, 5) = B2.Offset(, 5).Value
        Target.Offset(, 5).Font.ColorIndex = 1
        Target.Offset(, 10) = B2.Offset(, 4).Value
        Target.Offset(, 5).Font.ColorIndex = 1
End If
End If

End Sub

perry99 · 9 mrt 2011

Hallo HSV,

Bedankt voor jouw reaktie, helaas geen tijdwinst, het blijft hetzelfde.

Ik hoop dat je nog een andere oplossing hebt.

Alvast bedankt.

Groetjes,

Perry :thumb::thumb:

HSV · 9 mrt 2011

Helaas dus, probeer dit eens.

Code:

with Target
.Offset(, 1).ClearContents
.Offset(, 3).resize( ,2).value = B1.Offset(, 1).resize( ,2).Value
.Offset(, 5) = B1.Offset(, 4).Value
.Offset(, 10) = B1.Offset(, 3).Value
.Offset(0, 5).Font.ColorIndex = 1
end with

perry99 · 9 mrt 2011

Hallo HSV,

Wederom bedankt voor jouw reaktie, helaas geen tijdwinst, het blijft hetzelfde.

Ik hoop dat je nog een andere oplossing hebt.

Alvast bedankt.

Groetjes,

Perry :thumb::thumb::thumb:

Warme bakkertje · 10 mrt 2011

Beperk het zoekgebied door ipv Cells ofwel enkel de kolom met artikelnrs te doorzoeken met Columns(x) of indien de artikelnrs toch verspreid staan (wat mij onwaarschijnlijk lijkt) UsedRange te gebruiken.
Dit zou je toch al een significante tijdswinst moeten opleveren indien je XL2007 gebruikt om de waarde te vinden op de werkbladen aangezien hij dan 1 miljoen + rijen moet doorzoeken en bij een XL2003bestand slechts 65536, en niet te vergeten het aantal kolommen extra bij XL2007.

perry99 · 11 mrt 2011

Hallo Rudi,

Inderdaad gaat het iets sneller met Columns(x).
Ik ben er wel achter dat het probleem in navolgende zit:

x = Target.Value
If Len(x) = 6 Then x = "0" & Target.Value
If Len(x) = 5 Then x = "00" & Target.Value

Namelijk de nummers van B3 beginnen allemaal met een 1 en dat zou betekenen dat:

x = Target.Value
If Len(x) = 6 Then x = "10" & Target.Value
If Len(x) = 5 Then x = "100" & Target.Value

of

x = Target.Value

zou moeten zijn, maar hoe ik dat moet oplossen??????.

Ik hoop dat jij of iemand anders hiervoor een oplossing heeft.

Alvast bedankt voor het meedenken.

Groetjes,

Perry :thumb::thumb::thumb:

Warme bakkertje · 11 mrt 2011

Als ik je vraag goed begrijp zou onderstaande een oplossing moeten bieden

Code:

    With Target
        If Len(.Value) = 6 Then .Value = Left(.Value, 1) & "0" & Mid(.Value, 2, Len(.Value) - 1)
        If Len(.Value) = 5 Then .Value = Left(.Value, 1) & "00" & Mid(.Value, 2, Len(.Value) - 1)
    End With

cow18 · 11 mrt 2011

bij onderstaande moet er geen 3 keer gezocht worden als je bij de 1e keer al prijs had, want met de gegevens van die 2 laatste zoekacties wordt er toch niets gedaan.
De grootste tijdwinst moet je kunnen halen uit het beperken van het bereik waarbinnen die moet zoeken. Nu moet hij een volledig werkblad doorworstelen. Kan dat niet beperkt worden tot bepaalde rijen en/of bepaalde kolommen ?

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

  If Target.Row > 32 And Target.Column = 3 Then
    x = Target.Value
    If Len(x) = 6 Then x = "0" & Target.Value
    If Len(x) = 5 Then x = "00" & Target.Value

    Set B1 = Worksheets("9 Miljoen").Cells.Find(x, , xlValues, xlWhole)
    If Not B1 Is Nothing Then                              '9 MILJOEN
      Target.Offset(, 1).ClearContents
      Target.Offset(, 3) = B1.Offset(, 1).Value
      Target.Offset(, 4) = B1.Offset(, 2).Value
      Target.Offset(, 5) = B1.Offset(, 4).Value
      Target.Offset(, 10) = B1.Offset(, 3).Value
      Target.Offset(0, 5).Font.ColorIndex = 1
      Exit Sub
    End If

    Set B3 = Worksheets("Standaard").Cells.Find(x, , xlValues, xlWhole)
    If Not B3 Is Nothing Then                              'STANDAARD
      Target.Offset(, 1).ClearContents
      Target.Offset(, 3) = B3.Offset(, 1).Value
      Target.Offset(, 4) = B3.Offset(, 2).Value
      Target.Offset(, 5) = B3.Offset(, 3).Value
      Target.Offset(, 5).Font.ColorIndex = 3
      Target.Offset(, 12) = B3.Offset(, 9).Value
      Target.Offset(, 13) = B3.Offset(, 11).Value
      Exit Sub
    End If

    Set B2 = Workbooks("artikelbestand21.xls").Sheets("DSKNEW_P").Cells.Find(x, , xlValues, xlWhole)
    If Not B2 Is Nothing Then                              'ARTIKELBESTAND
      Target.Offset(, 1).ClearContents
      Target.Offset(, 3) = B2.Offset(, 1).Value
      Target.Offset(, 4) = B2.Offset(, 2).Value
      Target.Offset(, 5) = B2.Offset(, 5).Value
      Target.Offset(, 5).Font.ColorIndex = 1
      Target.Offset(, 10) = B2.Offset(, 4).Value
      Target.Offset(, 5).Font.ColorIndex = 1
      Exit Sub
    End If

    MsgBox "Artikelnummer niet gevonden!!!!!!", vbInformation, "Artikelnummer": Exit Sub

  End If
End Sub

Warme bakkertje · 11 mrt 2011

Bart, zie mijn opmerking Post#6

PS Nu al wakker ?

cow18 · 11 mrt 2011

ja, ik ben gewekt door een alarm, ben even gaan checken en ga zo weer onder de wol.
Als Warm Bakkertje ben je dan nu in de weer bij de oven ? Voor mij 4 croissants tegen een uur of 8 als het kan ????
Ik had blijkbaar over je reactie 6 gekeken, dus we zijn dezelfde mening toegedaan.

Warme bakkertje · 11 mrt 2011

Ben bezig sinds 23:00u en ga nog door tot ong 12:00 deze middag

(dagelijkse kost, in 't weekend een uurtje of 2 langer)

cow18 · 11 mrt 2011

bon, ik ben wakker, waar zijn de croissants ??

Roncancio · 11 mrt 2011

Je zou ...

Code:

x = Target.Value
    If Len(x) = 6 Then x = "0" & Target.Value
    If Len(x) = 5 Then x = "00" & Target.Value
Set B1 = Worksheets("9 Miljoen").Cells.Find(x, , xlValues, xlWhole)

... kunnen vervangen door...

Code:

Set B1 = Worksheets("9 Miljoen").UsedRange.Find(Format(Target.Value, "000000"), , xlValues, xlWhole)

Met vriendelijke groet,

Roncancio

cow18 · 11 mrt 2011

winst met die redenering ??? nog geen milliseconde, vermoed ik.

Roncancio · 11 mrt 2011

cow18 zei:
winst met die redenering ??? nog geen milliseconde, vermoed ik.

Welke redenering?
Zoals ik in mijn handtekening aangeef, wil ik graag mijn kennis vergroten.

Met vriendelijke groet,

Roncancio

cow18 · 11 mrt 2011

hieronder een macro die 1.000 keer hetzelfde doet en daarover de tijd meet. De verschillen zijn minimaal om niet te zeggen peanuts. Laat de macro een paar keer lopen en je zal zien dat de ene keer versie 1 sneller is dan jouw versie en omgekeerd.
De grote tijdswinst is het bereik waarbinnen je moet zoeken in de andere tabbladen drastisch te beperken, maar daarvoor moet je de layout kennen.

Code:

Sub VegelijkVersies()
  Dim x As Variant, i As Long, t As Double, v1 As Double, v2 As Double
  t = Timer
  For i = 0 To 1000
    If (i Mod 500) = 0 Then
      Select Case i
        Case 0: Range("A1") = 10000
        Case Else: Range("A1") = 100000
      End Select
    End If
    x = Range("A1").Value
    If Len(x) = 6 Then x = "0" & Range("A1").Value
    If Len(x) = 5 Then x = "00" & Range("A1").Value
  Next
  v1 = Timer - t

  t = Timer
  For i = 0 To 1000
  If (i Mod 500) = 0 Then
      Select Case i
        Case 0: Range("A1") = 10000
        Case Else: Range("A1") = 100000
      End Select
    End If
    x = Format(Range("a1").Value, "000000")
  Next
  v2 = Timer - t

  MsgBox "1e versie = " & v1 & " sec" & vbLf & "versie Roncancio = " & v2 & " sec" & vbLf & "dit is een verschil van " & (v1 - v2) / 1000 & " sec per bewerking"
End Sub

]

cow18 · 11 mrt 2011

overal chronos tussengeplaatst zo weet je waar je je tijd verdoet (of niet)

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim s As String, t As Double, x As Variant, B1 As Range, B2 As Range, B3 As Range
  t = Timer
  If Target.Row > 32 And Target.Column = 3 Then
    x = Target.Value
    If Len(x) = 6 Then x = "0" & Target.Value
    If Len(x) = 5 Then x = "00" & Target.Value
    s = s & Timer - t & " sec bij 1e chrono" & vbLf

    Set B1 = Worksheets("9 Miljoen").Cells.Find(x, , xlValues, xlWhole)
    s = s & Timer - t & " sec einde zoeken B1" & vbLf

    If Not B1 Is Nothing Then                              '9 MILJOEN
      Target.Offset(, 1).ClearContents
      Target.Offset(, 3) = B1.Offset(, 1).Value
      Target.Offset(, 4) = B1.Offset(, 2).Value
      Target.Offset(, 5) = B1.Offset(, 4).Value
      Target.Offset(, 10) = B1.Offset(, 3).Value
      Target.Offset(0, 5).Font.ColorIndex = 1
      s = s & Timer - t & " sec na B1 gevonden" & vbLf
      GoTo boodschap
    End If

    Set B3 = Worksheets("Standaard").Cells.Find(x, , xlValues, xlWhole)
    s = s & Timer - t & " sec einde zoeken B3" & vbLf
    If Not B3 Is Nothing Then                              'STANDAARD
      Target.Offset(, 1).ClearContents
      Target.Offset(, 3) = B3.Offset(, 1).Value
      Target.Offset(, 4) = B3.Offset(, 2).Value
      Target.Offset(, 5) = B3.Offset(, 3).Value
      Target.Offset(, 5).Font.ColorIndex = 3
      Target.Offset(, 12) = B3.Offset(, 9).Value
      Target.Offset(, 13) = B3.Offset(, 11).Value
      s = s & Timer - t & " sec na B3 gevonden" & vbLf
      GoTo boodschap
    End If

    Set B2 = Sheets("DSKNEW_P").Cells.Find(x, , xlValues, xlWhole)  'enkel voor test, ik had geen ander werkboek
    'Set B2 = Workbooks("artikelbestand21.xls").Sheets("DSKNEW_P").Cells.Find(x, , xlValues, xlWhole)
    s = s & Timer - t & " sec einde zoeken B2" & vbLf
    If Not B2 Is Nothing Then                              'ARTIKELBESTAND
      Target.Offset(, 1).ClearContents
      Target.Offset(, 3) = B2.Offset(, 1).Value
      Target.Offset(, 4) = B2.Offset(, 2).Value
      Target.Offset(, 5) = B2.Offset(, 5).Value
      Target.Offset(, 5).Font.ColorIndex = 1
      Target.Offset(, 10) = B2.Offset(, 4).Value
      Target.Offset(, 5).Font.ColorIndex = 1
      s = s & Timer - t & " sec na B2 gevonden" & vbLf
      GoTo boodschap
    End If

    s = s & Timer - t & " sec en niets gevonden" & vbLf
    MsgBox "Artikelnummer niet gevonden!!!!!!", vbInformation, "Artikelnummer"

boodschap:
    MsgBox s

  End If
End Sub

perry99 · 11 mrt 2011

Goedemiddag toppers,

Jullie waren er al vroeg bij "RESPEKT" :thumb:

De oplossing Post#9 van Cow18 is inderdaad zeer snel, zoektijd van B1 en B3 en geldt ook eigenlijk ook voor B2, echter als ik het laatste nummer zoek op regel 64877, dan doet die er ongeveer 1 seconde over.

Het zoekgebied van de nummers zijn:
B1 = C6 : C23
B2 = A1 : A64877
B3 = C6 : C100

Ik weet niet of jullie het nu nog sneller kunnen maken, maar ik ben jullie al zeer dankbaar.

Alvast bedankt voor het meedenken naar mijn probleem.

Groetjes,

Perry :thumb::thumb::thumb:

Warme bakkertje · 11 mrt 2011

Vervang Cells door bij
B1 >> Range("C6:C23")
B2 >> Range("A1:A64877")
B3 >> Range("C6:C100")
maar om eerlijk te zijn, wat is een zoektijd van 1 sec ?

Vba loopt gedeeltelijk erg traag

Gebruiker

Inventaris

Gebruiker

Inventaris

Gebruiker

Meubilair

Gebruiker

Meubilair

Terugkerende gebruiker

Meubilair

Terugkerende gebruiker

Meubilair

Terugkerende gebruiker

Meubilair

Terugkerende gebruiker

Meubilair

Terugkerende gebruiker

Terugkerende gebruiker

Gebruiker

Meubilair

Wij waarderen jouw privacy