Optimisation de code VBA

Le 25/05/2018 à 10:17

Bonjour,

j'ai un fichier qui me sert à réaliser des calculs.

Pour ce faire j'ai en premier lieu une feuille "base de données" qui contient un tableau (mode tableau) du même nom.

Je rentre l'ensemble de mes données qui sont répertoriées en ligne.

Ensuite je lance une macro afin que les autres tableaux (dans des feuilles différentes) se mettent à jour du même nombre de ligne avec tout ou partie des renseignements contenus dans les lignes.

Les calculs peuvent alors s'opérer.

Tout fonctionne correctement en injectant plus de 100 000 lignes mais:

  • le temps de traitement est long
  • parfois impossible de réouvrir le fichier si on le ferme (config : win7pro 64 et excel 2016 64 , 16 go ram et un i5)

cela me contraint à faire un copier coller valeur sur une autre feuille.

Par ailleurs je désactive aussi le calcul automatique du classeur que je ne lance en manuel qu'après.

Ma demande:

je souhaiterai savoir si la durée du traitement est lié à "l'architecture" de la macro et comme je ne suis pas spécialiste bien qu'elle fonctionne j'imagine qu'elle peut être optimisée

je vous joins le code pour avoir vos avis, merci

Private Sub BoutonMàJDonnées_Click()

    Application.ScreenUpdating = False

    Dim NbLignes As Long
    'Entrée manuelle du nouveau nombre de lignes que doit posséder l'onglet "Base de données"
    NbLignes = Application.InputBox(prompt:="Entrez le nombre de N.", Type:=1)

        If NbLignes > 0 Then
            NbLignes = NbLignes + 3
            'Mise à jour du nombre de lignes du tableau de l'onglet "Base de données"
            Sheets("Base de données").Select
            ActiveSheet.ListObjects("TableauBASEDEDONNEES").Resize Range(Cells(3, 1), Cells(NbLignes, 22))

            'Mise à jour du nombre de lignes du tableau de l'onglet "M_SEG"
            Sheets("M_Seg").Select
            ActiveSheet.ListObjects("TableauMSEG").Resize Range(Cells(3, 1), Cells(NbLignes, 14))

            'Mise à jour du nombre de lignes du tableau de l'onglet "M_Pré"
            Sheets("M_Pré").Select
            ActiveSheet.ListObjects("TableauMPRE").Resize Range(Cells(3, 1), Cells(NbLignes, 34))

            'Mise à jour du nombre de lignes du tableau de l'onglet "M_Séc"
            Sheets("M_Séc").Select
            ActiveSheet.ListObjects("TableauMSEC").Resize Range(Cells(3, 1), Cells(NbLignes, 14))

            'Mise à jour du nombre de lignes du tableau de l'onglet "M_Pla"
            Sheets("M_Pla").Select
            ActiveSheet.ListObjects("TableauMPLA").Resize Range(Cells(3, 1), Cells(NbLignes, 170))

            'Dans le cas où l'on diminue le nombre de lignes dans l'onglet "Base de données" :
            'On nettoie les lignes "en surplus" des autres onglets

            Sheets("M_Seg").Activate
            Dim MSegDernLigne As Long
                MSegDernLigne = Sheets("M_Seg").Range("A1048576").End(xlUp).Row
            If MSegDernLigne > NbLignes Then
                Sheets("M_Seg").Rows(NbLignes + 1 & ":" & MSegDernLigne).Select
                Selection.ClearContents
            End If

            Sheets("M_Pré").Activate
            Dim MPreDernLigne As Long
                MPreDernLigne = Sheets("M_Pré").Range("A1048576").End(xlUp).Row
            If MPreDernLigne > NbLignes Then
                Sheets("M_Pré").Rows(NbLignes + 1 & ":" & MPreDernLigne).Select
                Selection.ClearContents
            End If

            Sheets("M_Séc").Activate
            Dim MSecDernLigne As Long
                MSecDernLigne = Sheets("M_Séc").Range("A1048576").End(xlUp).Row
            If MSecDernLigne > NbLignes Then
                Sheets("M_Séc").Rows(NbLignes + 1 & ":" & MSecDernLigne).Select
                Selection.ClearContents
            End If

            Sheets("M_Pla").Activate
            Dim MPlaDernLigne As Long
                MPlaDernLigne = Sheets("M_Pla").Range("A1048576").End(xlUp).Row
            If MPlaDernLigne > NbLignes Then
                Sheets("M_Pla").Rows(NbLignes + 1 & ":" & MPlaDernLigne).Select
                Selection.ClearContents
            End If

                    For a = NbLignes + 1 To 18
                        For b = 10 To 35

                        Next
                    Next
                End If

End Sub
Le 25/05/2018 à 13:49

Bonjour,

je commencerais par supprimer les "Select" ou "Activate" inutiles, puis si j'ai bien compris les tableaux ont en définitive la même taille, donc la recherche de la dernière ligne peut être faite qu'une fois...

Voici le code "nettoyé" :

Private Sub BoutonMàJDonnées_Click()
    Application.ScreenUpdating = False
    Dim NbLignes As Long
    'Entrée manuelle du nouveau nombre de lignes que doit posséder l'onglet "Base de données"
    NbLignes = Application.InputBox(prompt:="Entrez le nombre de NNO.", Type:=1)
    If NbLignes > 0 Then
         NbLignes = NbLignes + 3
         'Mise à jour du nombre de lignes du tableau de l'onglet "Base de données"
         Sheets("Base de données").ListObjects("TableauBASEDEDONNEES").Resize Range(Cells(3, 1), Cells(NbLignes, 22))
         'Mise à jour du nombre de lignes du tableau de l'onglet "M_SEG"
         Sheets("M_Seg").ListObjects("TableauMSEG").Resize Range(Cells(3, 1), Cells(NbLignes, 14))
         'Mise à jour du nombre de lignes du tableau de l'onglet "M_Pré"
         Sheets("M_Pré").ListObjects("TableauMPRE").Resize Range(Cells(3, 1), Cells(NbLignes, 34))
         'Mise à jour du nombre de lignes du tableau de l'onglet "M_Séc"
         Sheets("M_Séc").ListObjects("TableauMSEC").Resize Range(Cells(3, 1), Cells(NbLignes, 14))
         'Mise à jour du nombre de lignes du tableau de l'onglet "M_Pla"
         Sheets("M_Pla").ListObjects("TableauMPLA").Resize Range(Cells(3, 1), Cells(NbLignes, 170))
         'Sheets("M_Seg").Activate
         Dim DernLigne As Long
         DernLigne = ActiveSheet.Range("A1048576").End(xlUp).Row
         If DernLigne > NbLignes Then
             Sheets("M_Seg").Rows(NbLignes + 1 & ":" & MSegDernLigne).ClearContents
             Sheets("M_Pré").Rows(NbLignes + 1 & ":" & MPreDernLigne).ClearContents
             Sheets("M_Séc").Rows(NbLignes + 1 & ":" & MSecDernLigne).ClearContents
             Sheets("M_Pla").Rows(NbLignes + 1 & ":" & MPlaDernLigne).ClearContents
         End If
         For a = NbLignes + 1 To 18
             For b = 10 To 35
             Next
         Next
    End If
End Sub

Pas essayé...

@ bientôt

LouReeD

Le 25/05/2018 à 15:53

Bonjour,

merci, vu pour l'évitement des répétitions finalement inutiles.

Oui les tableaux ont la même taille, seule diffère le nombre de colonnes.

Le code fonctionne à l'exception du "clearcontents".

Ca redimensionne bien les tableaux au bon nombre de lignes mais le contenu des cellules ne s'efface pas alors que la commande "d'effacement" est la même?

j'ai ajouté .select devant clearcontents , ça fonctionne mais peut-êter peut on le mettre en déclaratif au début ?

J'essaierai lundi de tester sur un nombre important de lignes.

Private Sub BoutonMàJDonnées_Click()
    Application.ScreenUpdating = False

    Dim NbLignes As Long

    'Entrée manuelle du nouveau nombre de lignes que doit posséder l'onglet "Base de données"
    NbLignes = Application.InputBox(prompt:="Entrez le nombre de N.", Type:=1)

    If NbLignes > 0 Then

         NbLignes = NbLignes + 3
         'Mise à jour du nombre de lignes du tableau de l'onglet "Base de données"
         Sheets("Base de données").ListObjects("TableauBASEDEDONNEES").Resize Range(Cells(3, 1), Cells(NbLignes, 24))
         'Mise à jour du nombre de lignes du tableau de l'onglet "M_SEG"

         Sheets("M_Seg").ListObjects("TableauMSEG").Resize Range(Cells(3, 1), Cells(NbLignes, 15))
         'Mise à jour du nombre de lignes du tableau de l'onglet "M_Pré"

         Sheets("M_Pré").ListObjects("TableauMPRE").Resize Range(Cells(3, 1), Cells(NbLignes, 34))
         'Mise à jour du nombre de lignes du tableau de l'onglet "M_Séc"

         Sheets("M_Séc").ListObjects("TableauMSEC").Resize Range(Cells(3, 1), Cells(NbLignes, 14))
         'Mise à jour du nombre de lignes du tableau de l'onglet "M_Pla"

         Sheets("M_Pla").ListObjects("TableauMPLA").Resize Range(Cells(3, 1), Cells(NbLignes, 70))
         'Sheets("M_Seg").Activate

         Dim DernLigne As Long

         DernLigne = ActiveSheet.Range("A1048576").End(xlUp).Row
         If DernLigne > NbLignes Then
             Sheets("M_Seg").Rows(NbLignes + 1 & ":" & MSegDernLigne).Select.ClearContents
             Sheets("M_Pré").Rows(NbLignes + 1 & ":" & MPreDernLigne).Select.ClearContents
             Sheets("M_Séc").Rows(NbLignes + 1 & ":" & MSecDernLigne).Select.ClearContents
             Sheets("M_Pla").Rows(NbLignes + 1 & ":" & MPlaDernLigne).Select.ClearContents
         End If
         For a = NbLignes + 1 To 18
             For b = 10 To 35
             Next
         Next
    End If
End Sub
Le 25/05/2018 à 21:18

Bonsoir,

Vu !

sur les lignes de type :

Sheets("M_Seg").Rows(NbLignes + 1 & ":" & MSegDernLigne).ClearContents

il faut remplacer MSegDernLigne(et autre variable) par DernLigne

En effet, il n'y a plus qu'une variable de numéro de dernière ligne...

@ bientôt

LouReeD

Le 28/05/2018 à 09:31

Bonjour,

j'ai bien laisser "dernligne" seul mais alors que j'ai ajouté les "select ", en fait si j'efface des lignes du tableau base de données, ça redimensionne les autres tableaux mais sans en effacer le contenu ?

Par ailleurs pour la première partie de code je me demandais si d'entrer des variables et des boucles? permettraient aussi d’accélérer la vitesse d'exécution ?

Lorsque je lance un gros traitement (200 000 lignes) ça mouline longtemps

Mais peut-être aussi que finalement le conception du code importe peu dans ce genre de traitement ?

merci

Private Sub BoutonMàJDonnées_Click()
    Application.ScreenUpdating = False

    Dim NbLignes As Long

    'Entrée manuelle du nouveau nombre de lignes que doit posséder l'onglet "Base de données"
    NbLignes = Application.InputBox(prompt:="Entrez le nombre de N.", Type:=1)

    If NbLignes > 0 Then

         NbLignes = NbLignes + 3

         'Mise à jour du nombre de lignes du tableau de l'onglet "Base de données"
         Sheets("Base de données").ListObjects("TableauBASEDEDONNEES").Resize Range(Cells(3, 1), Cells(NbLignes, 24))

         'Mise à jour du nombre de lignes du tableau de l'onglet "M_SEG"
         Sheets("M_Seg").ListObjects("TableauMSEG").Resize Range(Cells(3, 1), Cells(NbLignes, 15))

         'Mise à jour du nombre de lignes du tableau de l'onglet "M_Pré"
         Sheets("M_Pré").ListObjects("TableauMPRE").Resize Range(Cells(3, 1), Cells(NbLignes, 34))

         'Mise à jour du nombre de lignes du tableau de l'onglet "M_Séc"
         Sheets("M_Séc").ListObjects("TableauMSEC").Resize Range(Cells(3, 1), Cells(NbLignes, 14))

         'Mise à jour du nombre de lignes du tableau de l'onglet "M_Pla"
         Sheets("M_Pla").ListObjects("TableauMPLA").Resize Range(Cells(3, 1), Cells(NbLignes, 70))

          'Dans le cas où l'on diminue le nombre de lignes dans l'onglet "Base de données" :
            'On nettoie les lignes "en surplus" des autres onglets

         Dim DernLigne As Long

         DernLigne = ActiveSheet.Range("A1048576").End(xlUp).Row

         If DernLigne > NbLignes Then

             Sheets("M_Seg").Rows(NbLignes + 1 & ":" & DernLigne).Select.ClearContents
             Sheets("M_Pré").Rows(NbLignes + 1 & ":" & DernLigne).Select.ClearContents
             Sheets("M_Séc").Rows(NbLignes + 1 & ":" & DernLigne).Select.ClearContents
             Sheets("M_Pla").Rows(NbLignes + 1 & ":" & DernLigne).Select.ClearContents

         End If

    End If
End Sub
Le 28/05/2018 à 10:19

Bonjour,

je n'ai pas testé en "vrai", mais le principe est celui-ci :

les lignes ne sont plus vidées de leur contenu, elles sont supprimées !

Le fichier :

6astrolab-loureed.xlsm (26.95 Ko)

@ bientôt

LouReeD

Le 30/05/2018 à 11:32

Bonjour,

merci mais j'ai testé et cela redimensionne bien le tableau mais ne supprime pas le contenu de la cellule.

La vérité doit être ailleurs

je vais creuser plus avant

@+

Le 30/05/2018 à 16:49

Bonjour,

correction de code non complète :

Option Explicit

Sub loureed()
    Application.ScreenUpdating = False
    Dim NbLignes As Long
    'Entrée manuelle du nouveau nombre de lignes que doit posséder l'onglet "Base de données"
    NbLignes = Application.InputBox(prompt:="Entrez le nombre de NNO.", Type:=1)
    If NbLignes > 0 Then
        NbLignes = NbLignes + 3
        Sheets("Base de données").ListObjects("Tableau1").Resize Range(Cells(3, 1), Cells(NbLignes, 22))
        Sheets("M_Seg").ListObjects("Tableau2").Resize Range(Cells(3, 1), Cells(NbLignes, 14))
        Sheets("M_Pré").ListObjects("Tableau3").Resize Range(Cells(3, 1), Cells(NbLignes, 34))
        Sheets("M_Séc").ListObjects("Tableau4").Resize Range(Cells(3, 1), Cells(NbLignes, 14))
        Sheets("M_Pla").ListObjects("Tableau5").Resize Range(Cells(3, 1), Cells(NbLignes, 170))
        Dim DernLigne As Long
        DernLigne = Sheets("Base de données").Range("A" & Rows.Count).End(xlUp).Row
        If DernLigne > NbLignes Then
            Sheets("Base de données").Rows(NbLignes + 1 & ":" & DernLigne).EntireRow.Delete
            Sheets("M_Seg").Rows(NbLignes + 1 & ":" & DernLigne).EntireRow.Delete
            Sheets("M_Pré").Rows(NbLignes + 1 & ":" & DernLigne).EntireRow.Delete
            Sheets("M_Séc").Rows(NbLignes + 1 & ":" & DernLigne).EntireRow.Delete
            Sheets("M_Pla").Rows(NbLignes + 1 & ":" & DernLigne).EntireRow.Delete
        End If
    End If
End Sub

Il faut remplcer des "3" par des "1"

@ bientôt

LouReeD

Rechercher des sujets similaires à "optimisation code vba"