Vba loopt gedeeltelijk erg traag

[cow18]

straks wordt dat dus een fractie van een seconde.
Als je klaar bent mogen al die lijnen met s=s & ... weer weg

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").Range("C6:C23").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").Range("C6:C100").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 = Workbooks("artikelbestand21.xls").Sheets("DSKNEW_P").Range("A1:A64877").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]

Hallo Rudi en Cow18,

Het draait nu als een speer.

Met de vorige oplossing zonder de range was ik natuurlijk al tevreden en Rudi je hebt gelijk met " wat is nu 1 seconde".

Ik heb een extra bericht geplaatst met de range B1, B2 B3.
Daar jij en Cow18 het erover hadden dat als de range van B1, B2 en B3 bekend zouden zijn, het verhaal nog sneller kon.

Nogmaals mijn grote RESPEKT voor het helpen oplossen van vele excel problemen van een ieder op deze site.

Groetjes,

Perry :thumb::thumb::thumb: