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

Procestijd VBA sub erg lang

Status
Niet open voor verdere reacties.
anton44

anton44

Verenigingslid
Lid geworden
20 mei 2005
Berichten
1.797
Het onderstaand script duurt bijna 6 seconden.
De bedoeling is dat de eigenschappen en formules van rij 5 overgebracht worden naar de rijen 8 tot de laatste ingevuld rij met ongedefinieerde celeigenschappen.
Het aantal rijen vanaf rij 8 varieert tussen 1 en ca 40

Is er een mogelijkheid door bv andere formuleringen deze tijd te verkorten?

Code: 
Sub RB105_Formules_kopiëren()  'Formules en opmaak kopiëren

    Dim dTime As Double
    dTime = Timer
    
    Application.ScreenUpdating = False
 
    Range("G5").Select
    Selection.Copy
    Range("G8:G" & [A65536].End(xlUp).Row).Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
 
    Range("J5:S5").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("J8:S" & [A65536].End(xlUp).Row).Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        
    Rows("5").Select
    Selection.Copy
    Rows("8:" & [A65536].End(xlUp).Row).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        
    Range("AB5").Select 'toegevoegd
    Application.CutCopyMode = False
    Selection.Copy
    Range("AB8:AB" & [A65536].End(xlUp).Row).Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        
    Range("AG5").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("AG8:AK" & [A65536].End(xlUp).Row).Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        
    Range("S5:S5").Select
    Application.CutCopyMode = False
    Selection.Copy
    
    Range("S8" & [A65536].End(xlUp).Row).Select
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
    
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("A1:A3").Select

    Debug.Print "05.0 RB_Formules", Timer - dTime
    
    Call RB106_Verplaatsen
    
End Sub
 
Laatst bewerkt:
Ik denk dat je een voorbeeldje moet plaatsen

gokje

Code: 
Sub RB105_Formules_kopiëren()
 Set ar = Union([G5], [J5:S5], [AB5], [AG5])
   For i = 3 To Cells(Rows.Count, 1).End(xlUp).Row - 5
    ar.Offset(i) = ar.Formula
   Next
End Sub
 
ik vond de voorzet goed gevonden en heb hem uitgeprobeerd.
ik tik de formule "+G4+4" in G5 en hem laten doorkopiëren naar beneden.
Blijkbaar kopieert hij netjes exact die formule door, dus kopieert die absoluut ipv. relatief, alhoewel er geen "$" in staan !
Achteraf gezien is dit resultaat ook wel logisch.

Ik zou meer baat zien in het vooraan de macro uitzetten van de events + screenupdating en de calculation op manual en op het einde terug inschakelen.
 
Laatst bewerkt:
@cow, zet er eens jokertekens in. Als het goed is wordt hij dan relatief, vond ik ook apart
 
ik heb het geprobeerd, maar zie geen verschil.
Moest jouw voorstel werken, dan zou dat inderdaad heel apart zijn.
 
Ik krijg het ook niet meer gereproduceerd...kijken wat TS zegt
 
Laatst bewerkt:
@JVeer, @cow18.
Bedankt.
Ik heb het voorstel ingebracht maar krijg niet de juiste uitkomst.
De vraag naar een werkend voorbeeld is zeer terecht. Ik heb daar wat tijd voor nodig om dat "privacyproof" te maken.
Vooruitlopend heb ik regelnummers toegevoegd in het script.
Daaraan gekoppeld de vraag welke regels vervangen moeten worden door het voorstel.

Code: 
Sub RB105_Formules_kopiëren()  'Formules en opmaak kopiëren

010    Dim dTime As Double
020    dTime = Timer
    
030    Application.ScreenUpdating = False
 
040    Range("G5").Select
050    Selection.Copy
060    Range("G8:G" & [A65536].End(xlUp).Row).Select
070    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
 
080    Range("J5:S5").Select
090    Application.CutCopyMode = False
100    Selection.Copy
110    Range("J8:S" & [A65536].End(xlUp).Row).Select
120    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        
130    Rows("5").Select
140    Selection.Copy
150    Rows("8:" & [A65536].End(xlUp).Row).Select
160    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        
170    Range("AB5").Select 'toegevoegd
180    Application.CutCopyMode = False
190    Selection.Copy
200    Range("AB8:AB" & [A65536].End(xlUp).Row).Select
210    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        
220    Range("AG5").Select
230    Application.CutCopyMode = False
240    Selection.Copy
250    Range("AG8:AK" & [A65536].End(xlUp).Row).Select
260    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        
270    Range("S5:S5").Select
280    Application.CutCopyMode = False
290    Selection.Copy
    
300    Range("S8" & [A65536].End(xlUp).Row).Select
310    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
    
320    Cells.Select
330    Cells.EntireColumn.AutoFit
340    Range("A1:A3").Select

350    Debug.Print "05.0 RB_Formules", Timer - dTime
    
360    Call RB106_Verplaatsen
    
End Sub
 
die screenupdating, die zal wel niet zoveel invloed hebben denk ik.
Zonder voorbeeld is het moeilijk gokken, dus op de goeie hoop ...

Misschien niet heel eerlijk voor de tijdsmeting en misschien ook voor de macro die er na komt, maar de plaats waar die 3 zaken terug ingeschakeld worden, dat kan ik van hier niet beoordelen.
Dus louter voor de tijdsmeting zou ik die 3 zaken eventueel verhuizen tot net voor die debug
Code: 
Sub RB105_Formules_kopiëren()                    'Formules en opmaak kopiëren

   Dim dTime   As Double
   dTime = Timer

   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
   Application.EnableEvents = False

   r = [A65536].End(xlUp).Row
   For Each ar In Array("G5", "J5:S5", "AB5", "AG5")
      With Range(ar)
         .Copy
         .Offset(3).Resize(r - 7).PasteSpecial Paste:=xlPasteFormulas
      End With
   Next
   Cells.EntireColumn.AutoFit

   Debug.Print "05.0 RB_Formules", Timer - dTime

   Call RB106_Verplaatsen

   Application.ScreenUpdating = True
   Application.Calculation = xlCalculationAutomatic
   Application.EnableEvents = True

End Sub
 
Laatst bewerkt:
Bij het maken van een voorbeeldbestand (Formtest.xlsm) constateerde ik dat de procestijd daarbij erg kort is.
Vervolgens ben ik in het oorspronkelijke bestand de tijden gaan opnemen van de verschillende stappen in de sub Formules kopiëren
Opvallend is de relatief lange tijd voor stap 4 (in het codevenster getoond).
Is daar winst te behalen?

Resultaten:
01.0 RB_Formules_1 0,04296875
02.0 RB_Formules_2 0,015625
03.0 RB_Formules_3 0,03125
04.0 RB_Formules_4 1,859375
05.0 RB_Formules_5 0,015625
06.0 RB_Formules_6 0,01953125
07.0 RB_Formules_7 0,015625
08.0 RB_Formules_8 0

Code: 
Dim dTime As Double
dTime = Timer
    Range("AB5:AB5").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("AB8:AB" & [A65536].End(xlUp).Row).Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
Debug.Print "04.0 RB_Formules_4", Timer - dTime
 
 

Bijlagen

Ik denk dat ik het probleem gevonden heb inclusief een oplossing.
In de te kopiëren formules zijn 2 zoekfuncties opgenomen. Dus direct na het kopiëren wordt de zoekfunctie gerund.
Door herberekening van stap 4 uit te schakelen en daarna weer in te schakelen wordt de procestijd aanmerkelijk korter. zie relevant deel van de code

04.0 RB_Formules_4 0,0546875

Code: 
Application.Calculation = xlManual
Dim dTime As Double
dTime = Timer

    Range("AB5:AB5").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("AB8:AB" & [A65536].End(xlUp).Row).Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        
Application.Calculation = xlAutomatic
Debug.Print "04.0 RB_Formules_4", Timer - dTime
 
Mooi dat het werkt. Wel zitten er veel Selects in je code. Die zorgen ook voor vertraging van Macro's.
In dit geval zal het minimaal zijn maar in een grotere codes heeft het wel degelijk vertraging.
 
JVeer zei:
Mooi dat het werkt. Wel zitten er veel Selects in je code. Die zorgen ook voor vertraging van Macro's.
In dit geval zal het minimaal zijn maar in een grotere codes heeft het wel degelijk vertraging.
Klik om te vergroten...

Zijn die Selects op een andere manier uit te voeren. With .... enz ?
 
Code: 
    Range("AB5:AB5").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("AB8:AB" & [A65536].End(xlUp).Row).Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

is hetzelfde als
Code: 
    Range("AB5:AB5").Copy
    Range("AB8:AB" & [A65536].End(xlUp).Row).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
 
@Haije. Bedankt voor je reactie.
Het werkt ! maar een tijdmeting laat een tragere afloop zien :confused:
vlgs voorstel: 01.0 RB_Formules_T5 3,78125
vlgs bestaand script: 01.0 RB_Formules_T5 1,90625
 
internet en alle andere meedraaiende programmas uitschakelen en dan de test overdoen.
Met die selects moet dat veel trager zijn !

Bovendien mag je je niet blindstaren op die chronometer, het 1e cijfer na de komma is nog een beetje indicatief met een grote korrel zout.
 
cow18 zei:
internet en alle andere meedraaiende programmas uitschakelen en dan de test overdoen.
Met die selects moet dat veel trager zijn !

Bovendien mag je je niet blindstaren op die chronometer, het 1e cijfer na de komma is nog een beetje indicatief met een grote korrel zout.
Klik om te vergroten...

Inderdaad.
Nu internet geblokkeerd en geen progs in de achtergrond
Resultaten
03.0 RB_Formules_T4 3,859375 met herberekening ingeschakeld
04.0 RB_Formules_T4 0,109375 met herberekening uitgeschakeld.
Dat de tijdmeting zoveel digits achter de komma aangeeft - het zij zo. Ik ben me bewust dat het erg suggestief is.
 
Allen bedankt voor het meedenken en het aandragen van suggesties & oplossingen.
Ik heb alle routines in de Sub weten aan te passen vlgs #13 en ben tevreden = Opgelost.

Fijne Feestdagen en een gezond 2021
 
die #13, dat is mijn #8 van gisterenavond met een loopje er in gebouwd.
Minder tikwerk
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan