Results 1 to 9 of 9

Thread: VBA Macro gets slower with every execution

  1. #1

    Thread Starter
    New Member
    Join Date
    Mar 2020
    Posts
    12

    VBA Macro gets slower with every execution

    I have a macro that reads (once per minute) last line of a .txt file to store in a string variable It close .txt file. It Check if there is a jpg file witch finish with last line to display it on VLC… Then close VLC after 1 minutes

    Problem:
    -macro gets slower with every execution.
    -Exel take more RAM with every execution take 29.9Mo on start.


    Take more than 100Mo after 24 hours


    I know a partial solution is to close and reopen the .xlsm file manually relaunch again. However, some time it take too many time to close and Have to force restart PC.
    What I'm asking is if there is another way to solve this, what I believe is to be a memory clearing issue?

    I have tried to
    1) Clear the Undo buffer (ActiveDocument.UndoClear) but it make an compilation error
    2) Save the document periodically. Unfortunaly it is read only for the panel PC => error

    How can I periodically clean the RAM usage?

    thanks. and Cheers

    My code:

    This workbook:
    Code:
    Option Explicit
    Private Sub Workbook_BeforeClose(Cancel As Boolean)
    
    StopTempo
    
    
    End Sub
    
    Private Sub Workbook_Open()
    
    Userform1.Show
    
    End Sub
    Module1
    Code:
    Option Explicit
    Dim Tps As Date
    Public cyclesPPT As Integer
    Public cptAffichage As Integer
    Dim RetVal As Long
    Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
    Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, _
       lpdwprocessid As Long) As Long
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, _
       ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, _
       ByVal nIndex As Long) As Long
    Private Const WM_CLOSE = &H10
    Private Const GWL_STYLE = (-16)
    Private Const WS_SYSMENU = &H80000
    
    Private Function CloseWindow(ByVal hwnd As Long, ByVal hInstance As Long) As Long
     
    Dim idproc As Long
     
    idproc = 0
     
    'reçoit dans idproc l'id du processus lié à cette fenêtre
    GetWindowThreadProcessId hwnd, idproc
    If (idproc = hInstance) And ((GetWindowLong(hwnd, GWL_STYLE) And WS_SYSMENU) = WS_SYSMENU) Then
         PostMessage hwnd, WM_CLOSE, 0, 0
    End If
     
    'obligatoire pour qu'EnumWindows continue l'énumération
    CloseWindow = True
     
    End Function
     
    Public Sub KillApp(hInstance As Long)
     
    EnumWindows AddressOf CloseWindow, hInstance
     
    End Sub
    Public Function KillProcess(ByVal ProcessName As String) As Boolean
        Dim svc As Object
        Dim sQuery As String
        Dim oproc
        Set svc = GetObject("winmgmts:root\cimv2")
        sQuery = "select * from win32_process where name='" & ProcessName & "'"
        For Each oproc In svc.execquery(sQuery)
            oproc.Terminate
        Next
        Set svc = Nothing
    End Function
    
    Public Function FichierExiste(MonFichier As String)
    'par Excel-Malin.com ( https://excel-malin.com )
    
       If MonFichier <> "" And Len(Dir(MonFichier)) > 0 Then
          FichierExiste = True
       Else
          FichierExiste = False
       End If
    End Function
    
    Sub Tempo()
    
    Application.DisplayAlerts = False
    
    Dim i As Integer
    Dim j As Integer
    
    'Programmation de l'évènement toutes les 1 minutes
    Tps = Now + TimeValue("00:01:00")
    KillProcess "vlc.exe"
    Application.OnTime Tps, "Tempo"
    
    On Error GoTo Fin
    Workbooks.Open Filename:="A:\Etuve.csv", ReadOnly:=True, local:=True
    'Workbooks.Open Filename:="S:\Peinture\Etuve.csv", ReadOnly:=True, local:=True
    
    Dim Ligneencours As Double
    Dim Référenceencours As Integer
    Ligneencours = Range("A65536").End(xlUp).Row
    
    'décallage = Nb ponts sur balancelle (R1) + nb ponts au déchargement (6)
    Ligneencours = Ligneencours - 62
    'gestion des balancelles vides
    While Cells(Ligneencours, 11) = "0"
    Ligneencours = Ligneencours + 1
    Wend
    Référenceencours = Cells(Ligneencours, 11).Value
    
    
    'déclarer le bon numéro
    Workbooks("Ouvrir fiche expedition v4-1.xlsm").Activate
    Userform1.TEXTE1.Text = Référenceencours
    Workbooks("Etuve.csv").Activate
    ActiveWorkbook.Close False
    Call OUVRIR_PPT
    
    'ThisWorkbook.Save (disable because error on ro file
    
    Application.DisplayAlerts = True
    
    Exit Sub
    
    'fin alternative en cas d'erreur
    Fin:
    On Error GoTo -1
    
    Application.DisplayAlerts = True
    
    End Sub
    Sub StopTempo()
        On Error Resume Next
        'Stopper la gestion de l'évènement OnTime en cours
        Application.OnTime Tps, "Tempo", , False
    End Sub
    Sub OUVRIR_PPT()
    cyclesPPT = cyclesPPT + 1
    cptAffichage = cptAffichage + 1
    
    Dim i As Integer
    Dim Chemin As String
    
    On Error GoTo Fin
    
    'trouver diapo CONDITIONNEMENT
    If cptAffichage < 6 Then
    Dim Chemin2 As String, Fichier As String
     
        'Définit le répertoire contenant les fichiers
        Chemin2 = "O:\FONDFABR\FONDEXPE\MODE_OPERATOIRE_EXPE\conditionnementv2\"
     
        'Boucle sur tous les fichiers jpg du répertoire.
        Fichier = Dir(Chemin2 & "*" & Userform1.TEXTE1.Text & ".jpg")
        'Utilisez la syntaxe suivante pour boucler sur tous les types de fichiers :
        'Fichier = Dir(Chemin & "*.*")
        If Len(Fichier) > 0 Then
     Chemin = Chemin2 & Fichier
        Else
        Userform1.TEXTE1.Text = "pa-trouvé"
            Chemin = "O:\FONDFABR\FONDEXPE\MODE_OPERATOIRE_EXPE\conditionnementv2\NoImage.jpg"
            End If
            If FichierExiste(Chemin) = True Then
            'c bon'
        Else
            Userform1.TEXTE1.Text = "pa-trouvé"
            Chemin = "O:\FONDFABR\FONDEXPE\MODE_OPERATOIRE_EXPE\conditionnementv2\NoImage.jpg"
            cyclesPPT = 0
        End If
    End If
        
      
    'Ouvrir fiche qualité
    If cptAffichage > 5 Then
        'Définit le répertoire contenant les fichiers
        Chemin2 = "O:\FONDFABR\FONDEXPE\MODE_OPERATOIRE_EXPE\conditionnementv2\Qualité\"
     
        'Boucle sur tous les fichiers jpg du répertoire.
        Fichier = Dir(Chemin2 & "*" & Userform1.TEXTE1.Text & ".png")
        'Utilisez la syntaxe suivante pour boucler sur tous les types de fichiers :
        'Fichier = Dir(Chemin & "*.*")
        If Len(Fichier) > 0 Then
     Chemin = Chemin2 & Fichier
        Else
        Userform1.TEXTE1.Text = "pa-trouvé"
            Chemin = "O:\FONDFABR\FONDEXPE\MODE_OPERATOIRE_EXPE\conditionnementv2\Qualité\NoImage.jpg"
            End If
            If FichierExiste(Chemin) = True Then
            'c bon'
        Else
            Userform1.TEXTE1.Text = "pa-trouvé"
            Chemin = "O:\FONDFABR\FONDEXPE\MODE_OPERATOIRE_EXPE\conditionnementv2\Qualité\NoImage.jpg"
            cyclesPPT = 0
            cptAffichage = 0
            'ActiveDocument.UndoClear fonctionne pas
        End If
    End If
    
    'Rien a signaler qualité (mode auto)
        Chemin2 = "O:\FONDFABR\FONDEXPE\MODE_OPERATOIRE_EXPE\conditionnementv2\Qualité\"
        Fichier = Dir(Chemin2 & "*" & Userform1.TEXTE1.Text & ".png")
        'Utilisez la syntaxe suivante pour boucler sur tous les types de fichiers :
        'Fichier = Dir(Chemin & "*.*")
            If Len(Fichier) = 0 Then
    cptAffichage = 3
            End If
    If cptAffichage > 10 Then
       cptAffichage = 0
    End If
    
         'MsgBox (Chemin)
    
    'consigne ne pas passer sous une charge
    If cyclesPPT > 23 Then
    Chemin = "O:\FONDFABR\FONDEXPE\MODE_OPERATOIRE_EXPE\Chargement\sous-charge.jpg"
    End If
    If cyclesPPT > 25 Then
    cyclesPPT = 0
    'ActiveDocument.UndoClear (disable because doesn't work: error compilation unknow variable)
    End If
    
        RetVal = Shell("C:\Program Files (x86)\VideoLAN\VLC\vlc.exe " & Chemin, vbMaximizedFocus = True)
        RetVal = Shell("C:\Program Files (x86)\VideoLAN\VLC\vlc.exe " & Chemin, vbMaximizedFocus = True)
        RetVal = Shell("C:\Program Files (x86)\VideoLAN\VLC\vlc.exe " & Chemin, vbMaximizedFocus = True)
        RetVal = Shell("C:\Program Files (x86)\VideoLAN\VLC\vlc.exe " & Chemin, vbMaximizedFocus = True)
        RetVal = Shell("C:\Program Files (x86)\VideoLAN\VLC\vlc.exe " & Chemin, vbMaximizedFocus = True)
        RetVal = Shell("C:\Program Files (x86)\VideoLAN\VLC\vlc.exe " & Chemin, vbMaximizedFocus = True)
    
    
    Fin:
    On Error GoTo -1
    
    End Sub

  2. #2

    Thread Starter
    New Member
    Join Date
    Mar 2020
    Posts
    12

    Re: VBA Macro gets slower with every execution

    Hi,

    I have no nexs and the problem still occure

    VBA is alw&ays taking more and more ram and crash
    after 12 hours It take 224Mo instead of 30Mo ant crash

    How to free ram without restart excel?
    what is the syntax?

  3. #3
    PowerPoster
    Join Date
    Dec 2004
    Posts
    25,428

    Re: VBA Macro gets slower with every execution

    I have a macro that reads (once per minute) last line of a .txt file
    how are you firing the one minute event?

    i would avoid (find an alternative to) all lines that select, activate or use any selection or active anything

    does it really require a userform for this operation? are there any controls on the form that require references?
    i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
    Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next

    dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part

    come back and mark your original post as resolved if your problem is fixed
    pete

  4. #4

    Thread Starter
    New Member
    Join Date
    Mar 2020
    Posts
    12

    Re: VBA Macro gets slower with every execution

    Hi
    to enable the one minutes event I do
    Code:
    'Programmation de l'évènement toutes les 1 minutes
    Tps = Now + TimeValue("00:01:00")
    To disable it I do
    Code:
    Sub StopTempo()
        On Error Resume Next
        'Stopper la gestion de l'évènement OnTime en cours
        Application.OnTime Tps, "Tempo", , False
    End Sub
    and add on 'ThisWorkbook'
    Code:
    Option Explicit
    Private Sub Workbook_BeforeClose(Cancel As Boolean)
    
    StopTempo
    
    End Sub
    I need userform to stop tempo and load manualy some presentation ( to check if it is updated and what to focus in our process) this is done by every laborer, ( even those who have never use Office)

    Unfortunally I have found no alternative to all lines that select, activate or use any selection or active anything. and everybody said me that ActiveDocument.UndoClear Or ThisWorkbook.Save should purge every undo story without any exception but ActiveDocument.UndoClear work only with Word
    ThisWorkbook.Save doesn't work on Read only file

    How can I manage to free RAM... with VBA for Excel please?
    Last edited by benjibasson83; Jun 17th, 2021 at 12:51 AM.

  5. #5
    PowerPoster
    Join Date
    Dec 2004
    Posts
    25,428

    Re: VBA Macro gets slower with every execution

    How can I manage to free RAM... with VBA for Excel please?
    by not filling it first is the best method

    personally i would change from using application.ontime, change to an API timer

    Unfortunally I have found no alternative to all lines that select, activate
    simplest example
    Workbooks("Etuve.csv").Activate
    ActiveWorkbook.Close False
    Code:
    Workbooks("Etuve.csv").Close False
    ActiveDocument.UndoClear
    actions and editing to worksheets done from excel vba do not add to the undo list and can not be undone from excel
    i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
    Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next

    dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part

    come back and mark your original post as resolved if your problem is fixed
    pete

  6. #6

    Thread Starter
    New Member
    Join Date
    Mar 2020
    Posts
    12

    Re: VBA Macro gets slower with every execution

    Quote Originally Posted by westconn1 View Post
    by not filling it first is the best method

    personally i would change from using application.ontime, change to an API timer


    simplest example

    Code:
    Workbooks("Etuve.csv").Close False
    actions and editing to worksheets done from excel vba do not add to the undo list and can not be undone from excel
    Hi, if I change to an API timer, I cannot use userform because it will not respond at all. Worst: I cannot close excel by the red cross. the unic way to stop an running API timer is to do ctrl alt supp => task manager => force close
    => this is impossible because no keyboard on our production line

    I don't understand I have read the macro and I have seen zero line witch fill, refill refill to expense to 200Mo
    For me using application.ontime everwrite do fill only on first round. =30 Mo total excel... on 2nd round it should stay again 30Mo and on a million round should be still 30Mo
    Same for lines that select, activate or use any selection or active anything: it should fill ram once and basta.

    What is fill refill refilling to reach 200Mo?

    if you look at the sub tempo there is
    Code:
    Workbooks("inf.txt").Activate
    ActiveWorkbook.Close False
    More over
    Code:
    KillProcess "vlc.exe"
    Thus in automatic mode,
    -each time it open a file it close it properly
    -Each time it open external application it close it properly...

    is there a way to put a spy witch give me what fill ram
    to have instructions to unfill ram taken by Microsoft Excel - unic-file.xlsm - Excel

  7. #7

    Thread Starter
    New Member
    Join Date
    Mar 2020
    Posts
    12

    Re: VBA Macro gets slower with every execution

    For me, nothing at all justify this

    after only 2880 cycles VBA still fill extra ram althought there is no new dim variables at all
    althought
    Code:
    Sub StopTempo()
        On Error Resume Next
        'Stopper la gestion de l'évènement OnTime en cours
        Application.OnTime Tps, "Tempo", , False
    End Sub
    have never been call during these 48 last hours
    althought no change has been done on Ouvrir Vidéo Supérieur.xlsm
    altought all lines that select, activate or use any selection or active anything shouldn't fill extra, refill refill without free ram... it should only fill only once ram during the start of macro

  8. #8

    Thread Starter
    New Member
    Join Date
    Mar 2020
    Posts
    12

    Re: VBA Macro gets slower with every execution

    Hi,
    I still have no solution:
    1) why excell stil fill fill fill fill 220 Mo of ram for no ground at all without cleaning althought there is only one instance ( booth file.txt and external applications are closed properly)
    2) How to clean ram without any human intervention at all? ( without stop vba neither excell)

    thanks

    Code:
    Sub Tempo()
    
    Dim i As Integer
    Dim j As Integer
    Dim Chemin As String
    Dim FicheQual As Integer
    Dim RetVal As Long
    
    
    'Programmation de l'évènement toutes les 2 minutes 00
    Tps = Now + TimeValue("00:02:00")
    Application.OnTime Tps, "Tempo"
    
    Application.DisplayAlerts = False
    
    On Error GoTo FinErreur
    
    Userform1.Label1.Caption = Now()
    
    KillProcess "vlc.exe"
    Range("A1").Copy Range("A1") 'this should delete undo story
    Workbooks.Open Filename:="P:\inf.txt", ReadOnly:=True, local:=True
    'Workbooks.Open Filename:="Y:\inf.txt", ReadOnly:=True, local:=True
    
    
    Dim Ligneencours As Integer
    Dim Référenceencours As Integer
    Ligneencours = Range("A65536").End(xlUp).Row
    
    If Cells(3, 1).Value = "" Then
    Workbooks("inf.txt").Activate
    ActiveWorkbook.Close False
    Application.DisplayAlerts = True
    Exit Sub
    End If
    
    While Cells(Ligneencours, 1) <> ""
    Ligneencours = Ligneencours + 1
    Wend
    Référenceencours = Cells(Ligneencours - 1, 1).Value
    
    'faire le lien entre numéro de plaque modèle et numéro de référence
    Workbooks("Ouvrir vidéo Manchon.xlsm").Activate
    For i = 2 To 300 Step 1
        If Cells(i, 7).Value = Référenceencours Then
            If Cells(i, 4).Value <> "pas de vidéo" Then
            Userform1.TEXTE1.Text = Cells(i, 2).Value
            Chemin = Feuil1.Range("C" & i).Value
            Else
            Userform1.TEXTE1.Text = 9999
            Chemin = "O:\FONDFABR\FONDMOUL\MODE_OPERATOIRE_L17\REMMOULAGE_INFERIEUR\NoVidéo.mp4"
            End If
        End If
    Next
    
    Workbooks("inf.txt").Activate
    ActiveWorkbook.Close False
    
    'Chargement vidéo par VLC en auto
    'KillApp (RetVal)'déplacement de la ligne
    cyclesVLC = cyclesVLC + 1
    'consigne ne pas passer sous une charge
    If cyclesVLC > 25 Then
    Chemin = "O:\FONDFABR\FONDMOUL\MODE_OPERATOIRE_L17\PROJET_VIDEO\fiches-secu\Mou-cable-manchons.jpg"
    End If
    If cyclesVLC > 26 Then
    cyclesVLC = 0
    End If
    
    RetVal = Shell("C:\Program Files (x86)\VideoLAN\VLC\vlc.exe " & Chemin, vbMaximizedFocus = True)
            
    'Ouverture fiche qualité
    'faire le lien entre numéro de plaque modèle et numéro de référence
    Workbooks("Ouvrir vidéo Manchon.xlsm").Activate
    For i = 2 To 300 Step 1
        If Cells(i, 7).Value = Référenceencours Then
            If Cells(i, 6).Value <> "Pas de fiche" Then
            FicheQual = 1
            Chemin = Feuil1.Range("E" & i).Value
            Else
            FicheQual = 0
            End If
        End If
    Next
    
    'Chargement Fiche par firefox en auto si présence fiche. sinon chargement vidéo
    
    If FicheQual = 1 Then
    RetVal = Shell("C:\Program Files (x86)\VideoLAN\VLC\vlc.exe " & Chemin, vbMaximizedFocus = True)
    RetVal = Shell("C:\Program Files (x86)\VideoLAN\VLC\vlc.exe " & Chemin, vbMaximizedFocus = True)
    RetVal = Shell("C:\Program Files (x86)\VideoLAN\VLC\vlc.exe " & Chemin, vbMaximizedFocus = True)
    RetVal = Shell("C:\Program Files (x86)\VideoLAN\VLC\vlc.exe " & Chemin, vbMaximizedFocus = True)
    RetVal = Shell("C:\Program Files (x86)\VideoLAN\VLC\vlc.exe " & Chemin, vbMaximizedFocus = True)
    End If
    
    
    Application.DisplayAlerts = True
    
    FinErreur:
    
    Application.DisplayAlerts = True
    On Error GoTo -1
    
    End Sub

  9. #9
    Fanatic Member
    Join Date
    Feb 2013
    Posts
    985

    Re: VBA Macro gets slower with every execution

    Office is far from perfect, in fact the more you use it the more problems you find with it. workarounds are generally the way to go in these cases.

    I recommend setting up something that just closes and reopens the file since you said that seems to work.

    something very basic would be open the file again in a new excel app, close the current one. do that every hour or so.
    Yes!!!
    Working from home is so much better than working in an office...
    Nothing can beat the combined stress of getting your work done on time whilst
    1. one toddler keeps pressing your AVR's power button
    2. one baby keeps crying for milk
    3. one child keeps running in and out of the house screaming and shouting
    4. one wife keeps nagging you to stop playing on the pc and do some real work.. house chores
    5. working at 1 O'clock in the morning because nobody is awake at that time
    6. being grossly underpaid for all your hard work


Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width