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

Optimalisatie macro code

Status
Niet open voor verdere reacties.

anton44

Verenigingslid
Lid geworden
20 mei 2005
Berichten
1.597
Als vervolg op een eerder geplaatst topic http://www.helpmij.nl/forum/showthread.php/937137-Macro-s-in-Excel-2010-vs-Excel-2016 vermoedt ik dat de volgende code geoptimaliseerd kan worden om snelheidswinst te behalen.
("Select" zou vermeden moeten worden)
Code:
Sub Macro_R()

     Application.ScreenUpdating = False
     Application.EnableEvents = False
     
     ActiveWorkbook.Worksheets("ToekBet").Select
     
     Range("T10:U40").Select
     Selection.ClearContents

     Range("R" & Range("R6").Value & ":R" & Range("R7").Value).Select
     Selection.Copy
     Range("T" & Range("R6").Value & ":T" & Range("R7").Value).Select
     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
     If Range("R8") < 32 Then
        Else
        GoTo Alleen_R
     End If
        
     Range("S" & Range("S6").Value & ":S" & Range("S7").Value).Select
     Selection.Copy
     Range("U" & Range("S6").Value & ":U" & Range("S7").Value).Select
     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
Alleen_R:
    Range("R" & Range("R7").Value & ":R" & Range("R7").Value).Select
    Selection.Copy
    Range("U" & Range("R7").Value & ":U" & Range("R7").Value).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    Application.CutCopyMode = False
    Application.Goto Range("B4")
  
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
End Sub
 
Anton, probeer dit eens:

Code:
Sub Macro_R()

     Application.ScreenUpdating = False
     Application.EnableEvents = False
     
     With Worksheets("ToekBet")
     
     .Range("T10:U40").ClearContents

     .Range("R" & Range("R6").Value & ":R" & Range("R7").Value).Copy .Range("T" & .Range("R6") & ":T" & .Range("R7"))
      .Range("T" & Range("R6") & ":T" & Range("R7"))=.Range("T" & .Range("R6") & ":T" & .Range("R7")).value

     If .Range("R8") < 32 Then GoTo Alleen_R
        
     .Range("S" & Range("S6").Value & ":S" & Range("S7").Value).Copy .Range("U" & .Range("S6")& ":U" & .Range("S7"))
     .Range("U" & .Range("S6")& ":U" & .Range("S7"))=.Range("U" & .Range("S6")& ":U" & .Range("S7")).value
    
Alleen_R:
    .Range("R" & Range("R7").Value & ":R" & Range("R7").Value).Copy .Range("U" & .Range("R7")& ":U" & .Range("R7"))
    .Range("U" & .Range("R7")& ":U" & .Range("R7"))=.Range("U" & .Range("R7")& ":U" & .Range("R7")).value
    
End With

    Application.CutCopyMode = False
    Application.Goto Range("B4")
  
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
End Sub
 
Hi Haije,
Bedankt voor je snelle reactie. Mijn test laat echter nog een bug(je) zien. Het resultaat is niet identiek:confused:
 
Met een timer heb ik getracht inzicht te krijgen welke stappen voor de traagheid zorgen.
Het deel van die code met de timer-regels hieronder
Code:
Debug.Print "R2", Timer - dTime

     Range("S" & Range("S6").Value & ":S" & Range("S7").Value).Select
     Selection.Copy
     Range("U" & Range("S6").Value & ":U" & Range("S7").Value).Select
     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
Debug.Print "R3", Timer - dTime

Alleen_R:
    Range("R" & Range("R7").Value & ":R" & Range("R7").Value).Select
    Selection.Copy
    Range("U" & Range("R7").Value & ":U" & Range("R7").Value).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

   Debug.Print "R4", Timer - dTime
   
    Application.CutCopyMode = False
    
   Debug.Print "R5", Timer - dTime
    
    Application.Goto Range("B4")
  
 Debug.Print "R6", Timer - dTime
 
    Application.EnableEvents = True
    
 Debug.Print "R7", Timer - dTime
    
    Application.ScreenUpdating = True
    
Debug.Print "R8", Timer - dTime
    
End Sub

R1 0,015625
R2 0,03125
R3 0,046875
R4 1,90625
R5 1,90625
R6 1,90625
R7 1,90625
R8 1,921875

Hieruit concludeer ik dat de code na "Alleen R" verantwoordelijk is en voor de andere stappen nauwelijks iets te winnen valt (in tijd)
 
Weet je topic starters moeten eens leren om een gelijkend vb bestand te posten maar blijkbaar is dat bla bla tegen dovemans oren.
Als je werkt voor een of andere staatsveiligheid heb ik er alle begrip voor maar dan moet de staat maar een ITer inhuren en niet hier een vraag posten.
Dit gezegt zijnde, iets in die richting?
Code:
Sub Macro_R()
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
With Sheets("ToekBet")
    .Range("T10:U40").ClearContents
    .Range("R" & Range("R6").Value & ":R" & Range("R7").Value).Copy
    .Range("T" & Range("R6").Value & ":T" & Range("R7").Value).PasteSpecial Paste:=xlPasteValues
        If Range("R8") < 32 Then
        Else
        GoTo Alleen_R
     End If
        .Range("S" & Range("S6").Value & ":S" & Range("S7").Value).Copy
        .Range("U" & Range("S6").Value & ":U" & Range("S7").Value).PasteSpecial Paste:=xlPasteValues
Alleen_R:
    .Range("R" & Range("R7").Value & ":R" & Range("R7").Value).Copy
    .Range("U" & Range("R7").Value & ":U" & Range("R7").Value).PasteSpecial Paste:=xlPasteValues
End With
With Application
.CutCopyMode = False
.Goto Range("B4")
.EnableEvents = True
.ScreenUpdating = True
End With

End Sub
 
Laatst bewerkt:
Jammer dat je werkelijk niets doet met eerder gegeven adviezen. Waarom een helper moet zoeken naar een eerder gestelde vraag zal ook wel een bepaalde logica hebben.
 
@Philiep:
Van de ene kant heb ik begrip voor je smeekbede voor een vb bestand maar in dit geval is dat niet mogelijk omdat het te maken heeft met bankgegevens (zie mijn gerelateerde topic). Ik hoopte door een beperkt gebied van de macro te tonen de complexiteit weg te kunnen nemen.
Je code werkt wel. Met dank.
Ik heb enkele timers geplaatst en het resultaat is dat er jammer genoeg geen tijdwinst mee valt te behalen.
DJ1 0,0078125
DJ2 0,0390625
DJ3 0,0546875
DJ4 1,9140625
DJ5 1,9453125

@VenA
Leren doe je stapje voor stapje. Ik hoop zo als leek (geen opleiding in VBA) verder te komen. Ik probeer telkens de aangeboden stof te begrijpen. :confused:
 
Gebruik geen 'copy' maar value = value als je alleen maar de waarden wilt.
 
Gebruik geen 'copy' maar value = value als je alleen maar de waarden wilt.

Harry hartelijk dank.
Je opmerking heeft me op het juiste spoor gebracht.
Range(doel).value=Range(bron).value
In mijn script voor een van de regels is nu de code:
Code:
  .Range("T" & Range("R6") & ":T" & Range("R7")).Value = .Range("R" & Range("R6") & ":R" & Range("R7")).Value
Alles bij elkaar een constateerbare snelheidsverbetering. Het totale script runt nu in 0.0625 sec.
 
Omdate ik gebruik van Goto in code niet toejuich en omdat lezen uit excel cellen tijd kost hier mijn versie:
Code:
Option Explicit

Sub Macro_R()
    Dim lCelR6 As Long
    Dim lCelR7 As Long
    Dim lCelS6 As Long
    Dim lCelS7 As Long
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    With Sheets("ToekBet")
        .Range("T10:U40").ClearContents
        'Rijnummers slechts één keer lezen
        lCelR6 = .Range("R6").Value
        lCelR7 = .Range("R7").Value
        lCelS6 = .Range("S6").Value
        lCelS7 = .Range("S7").Value
        
        .Range("T" & lCelR6 & ":T" & lCelR7).Value = .Range("R" & lCelR6 & ":R" & lCelR7).Value
'Goto is een slecht idee, het lijdt tot "spaghetti code"
        If Range("R8") < 32 Then
            .Range("U" & lCelS6 & ":U" & lCelS7).Value = .Range("S" & lCelS6 & ":S" & lCelS7).Value
        End If
        .Range("U" & lCelR7 & ":U" & lCelR7).Value = .Range("R" & lCelR7 & ":R" & lCelR7).Value
    End With
    With Application
        .CutCopyMode = False
        .Goto Range("B4")
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub
 
Waar GoTo al niet toe kan leiden.....
 
Jan Karel,
Bedankt voor je afgeleverde werk. Blijkbaar zit er nog steeds een uitdaging in :)
De code werkt bijzonder goed. Ik heb nu huiswerk om hem te doorgronden.
Nogmaals mijn respect en dank.
 
Geoptimaliseerd.
Code:
Sub Macro_R()
Dim r6 As Long, r7 As Long, r7a As Long, s6 As Long, s7 As Long
With Sheets("ToekBet")
 r6 = .Range("r6").Value
 r7 = .Range("r7")
 s6 = .Range("s6").Value
 s7 = .Range("s7") - s6 + 1
 
    .Range("T10:U40").ClearContents
    .Range("t" & r6).Resize(r7 - r6 + 1) = .Range("R" & r6).Resize(r7 - r6 + 1).Value
      If .Range("R8") > 32 And s7 > 0 Then
         .Range("U" & s6).Resize(s7) = .Range("S" & s6).Resize(s7).Value
      End If
        .Range("U" & r7) = .Range("R" & r7).Value
 Application.Goto .Range("B4")
End With
End Sub
 
Harry, alweer hartstikke bedankt voor je inspanningen.
Een test wijst uit dat je voorgesteld code BIJNA goed is. Niet alle noodzakelijke waarden worden in U10:U40 gekopieerd. Zie beide schermafdrukken.
Om te weten waarom dit alles een beknopte afspiegeling:
Het hoofddoel is het tonen van een grafiek waarin "Gerealiseerd" en "Prognose" zichtbaar zijn.
R10:R40 wordt met formules gevuld met gerealiseerde data
S10:S40 idem voor prognose data
De met formules gevulde cellen kan ik niet gebruiken voor de grafieklijnen. Daarom worden de waarden daarvan gekopieerd in bereiken T en U.
De kopieergebieden worden bepaald door de waarden in R6, R7 resp S6, S7
FG-2018-05-26_120526.jpgFG-2018-05-26_121333.jpg
 
Gevonden ;)
Code:
      If .Range("R8") > 32 And s7 > 0 Then
te wijzigen in:
Code:
      If .Range("R8") < 32 And s7 > 0 Then

Is DIM R7a As Long niet overbodig ?

Als Feedback maar zeker niet als kritiek:
Timer meetingen
R04_HSV 0,09375
R04 _JKP 0,0625
 
Laatst bewerkt:
r7a is overbodig,

Zet sceenupdating eens op false.

Onderaan de code van JKP staan nog wat overbodige regels.
 
r7a is overbodig,

Zet sceenupdating eens op false.

Onderaan de code van JKP staan nog wat overbodige regels.

Na toevoeging van screenupdating false en wissen van 2 overbodige codes bij JKP
R04_HSV 0,046875
R04_JKP 0,046875
= exact gelijk.

Na diverse herhalingen van meeting
R04_JKP 0,0625
 
Laatst bewerkt:
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan