Efficienter schrijven Excel VBA Code

  • Onderwerp starter Onderwerp starter dprod
  • Startdatum Startdatum
Status
Niet open voor verdere reacties.
D

dprod

Gebruiker
Lid geworden
2 jun 2010
Berichten
80
Beste medeforum gebruikers,

Ik zou graag willen weten of er iemand suggesties heeft om de volgende code effecienter te schrijven/laten werken.
Zie Code...

Code: 
' deze code wordt geladen vanuit het workbook_change
' elke keer als de range A7 verandert moet er gekeken worden welke actie te ondernemen
' variabele Bestek is Public omdat deze zijn waarde moet behouden.

Option Explicit
Public Bestek As String
Public Const strDatabaseFile As String = "database.xls"

Public Sub CreateBestek()

    Dim Exist As Range

Application.ScreenUpdating = False


'als de variabele Bestek gelijk = aan waarde Range A7... niks doen!
If Bestek = Range("A7").Value Then
    Exit Sub
End If

'als de variabele Bestek gelijk = aan "" (niks dus!)... Range A13:C52 leeg maken
If Bestek = "" Then
    Bestek = Range("A7").Value 'geef de variabele Bestek zijn nieuwe waarde
    Range("A13:C52").ClearContents 'leeg maken
        On Error Resume Next ' = GEEN LOG MELDING VOOR NODIG
        Set Exist = Range("=" & strDatabaseFile & "!" & Bestek)
        If Not (Exist Is Nothing) Then
            Range("=" & strDatabaseFile & "!" & Bestek).Copy
            Range("A13").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
        End If
End If

'als de variabale Bestek <> NIET gelijk is aan Range A7... het nieuwe bestek kopie�ren
If Bestek <> Range("A7").Value Then
    Bestek = Range("A7").Value 'geef de variabele Bestek zijn nieuwe waarde
    Range("A13:C52").ClearContents 'oude bestek gegevens verwijderen
        On Error Resume Next ' als het bestek niet bestaat resume next
        Set Exist = Range("=" & strDatabaseFile & "!" & Bestek) ' geeft exist de waarde van de databasefile + de bestek naam
        If Not (Exist Is Nothing) Then 'als exist bestaat dan kopie�ren/plakken
            Range("=" & strDatabaseFile & "!" & Bestek).Copy
            Range("A13").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
        End If
End If
End Sub

Het vreemde is dat wanneer ik bij het gedeelte van de If statement:
If Bestek = "" Then

...NIET het stuk "On Error Resume Next" invoeg de code heeeeeel langzaam gaat.
Je zou namelijk zeggen dat dit daar voldoende moet zijn:
Code: 
If Bestek = "" Then
    Bestek = Range("A7").Value 'geef de variabele Bestek zijn nieuwe waarde
    Range("A13:C52").ClearContents 'leeg maken

Maar dit werkt dus heel langzaam op het moment dat ik Opnieuw een ander Onderhouds Bestek selecteer!
Ondanks de Application.ScreenUpdating = False

Iemand enig idee?
Alvast bedankt...

Gr, dprod
 
Gevonden!

Ik had natuurlijk de Range("") en Bestek vergelijking om moeten draaien!

Dus:
If Bestek = "" Then

Moest zijn:
If Range("A7").Value = "" Then

Zie Code...
Code: 
Public Sub CreateBestek()

    Dim Exist As Range

Application.ScreenUpdating = False

If Range("A7").Value = Bestek Then
    Exit Sub
End If

If Range("A7").Value = "" Then
    Bestek = Range("A7").Value
    Range("A13:C52").ClearContents
End If

If Range("A7").Value <> Bestek Then
    Bestek = Range("A7").Value
    Range("A13:C52").ClearContents
        On Error Resume Next ' = GEEN LOG MELDING VOOR NODIG
        Set Exist = Range("=" & strDatabaseFile & "!" & Bestek)
        If Not (Exist Is Nothing) Then
            Range("=" & strDatabaseFile & "!" & Bestek).Copy
            Range("A13").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
        End If
End If

End Sub

Status: opgelost... (eventueele suggesties voor nog efficienter schrijven mag natuurlijk)
 
Wat reageerd er trouwens sneller?

Een If Statement of een Case Select?
Daar zijn natuurlijk verschillende mogelijkheden...

Gr, dprod
 
Voor simpele vergelijkingen is een IF snel en overzichtelijk. Als je meerdere IF's en ELSEIF's moet gaan nesten dan is een Case veel overzichtelijker. Snelheid wordt pas een issue voor de moderne computer als er veel en diep genest wordt.

Ron

Sorry voor de late reactie
 
Ik heb er een Case Select van gemaakt, welke idd overzichtelijker is...
Naar mijn idee verloopt de code ook iets soepeler nu, daar mijn pc (van werk) niet de rekenkracht heeft van een JSF!

Zie Code...
Code: 
Public Sub CreateBestek()

    Dim Exist As Range

Application.ScreenUpdating = False

With Range("A7")
    Case Select .Value
        Case Is = Bestek
            Exit Sub
        Case Is = ""
            Bestek = Range("A7").Value
            Range("A13:C52").ClearContents
        Case Is <> Bestek
            Bestek = Range("A7").Value
            Range("A13:C52").ClearContents
                On Error Resume Next ' = GEEN LOG MELDING VOOR NODIG
                Set Exist = Range("=" & strDatabaseFile & "!" & Bestek)
                If Not (Exist Is Nothing) Then
                    Range("=" & strDatabaseFile & "!" & Bestek).Copy
                    Range("A13").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                            :=False, Transpose:=False
    End Select
End With
End Sub

Tot nu toe dus het meest efficient!
 
Na de laatste End With
Code: 
With Application
  .CutCopyMode = False
  .ScreenUpdating = True
End With
maakt het compleet.
 
Laatst bewerkt:
voor de formaliteit nog de complete code dan ;)

Code: 
Public Sub CreateBestek()

    Dim Exist As Range

Application.ScreenUpdating = False

With Range("A7")
    Select Case .Value
        Case Is = Bestek
            Exit Sub
        Case Is = ""
            Bestek = Range("A7").Value
            Range("A13:C52").ClearContents
        Case Is <> Bestek
            Bestek = Range("A7").Value
            Range("A13:C52").ClearContents
                On Error Resume Next ' = GEEN LOG MELDING VOOR NODIG
                Set Exist = Range("=" & strDatabaseFile & "!" & Bestek)
            If Not (Exist Is Nothing) Then
                Range("=" & strDatabaseFile & "!" & Bestek).Copy
                Range("A13").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                        :=False, Transpose:=False
            End If
    End Select
End With

With Application
    .ScreenUpdating = True
    .CutCopyMode = False
End With

End Sub

gr,
dprod
 
Toch altijd leuk, wat feedback :thumb:
 
Het stukje code:
Code: 
            If Not (Exist Is Nothing) Then
                Range("=" & strDatabaseFile & "!" & Bestek).Copy

kan natuurlijk gewoon dit worden:
Code: 
            If Not (Exist Is Nothing) Then
                Bestek.Copy

schilt weer 1 byte aan opslag voor de module :thumb: :cool:
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan