Accélérer les procédures avec un dispositif de fichiers liés

Le 04/07/2021 à 20:10

Bonjour,

J'ai réalisé un outil qui permet de suivre les stratégies de soin mises en place pour des animaux blessés ou malades.

L'ensemble des données est réuni dans un fichier très simple intitulé DEBRIEF_BASE, qui ne contient que des données et pas de macros. De la sorte ce fichier est partagé sur le serveur de l'association, ouvert et modifié depuis différents postes.

Mais, pour exploiter ces données, les soigneuses se servent en fait d'un autre fichier qui s'intitule "Debrief", qui ne contient que des formules et moultes macros, lesquelles permettent l'exploitation ergonomique des infos contenues dans DEBRIEF BASE (la lecture, l'ajout, le classement et les modification des différentes infos contenus dans le fichier DEBRIEF_BASE). les infos de DEBRIEF_BASE sont reportés dans les fichier-outils avec des formules INDEX.

Ce fichier-outil "debrief" existe en autant d'exemplaire qu'il y a de PCs reliés au serveur : debrief_salle de soin; debrief_bureau, etc.

Lorsque l'on ouvre un de ces fichiers "Debrief", le fichier de données DEBRIEF_BASE s'ouvre en arrière plan et reste invisible tout le temps (fichier masqué pour éviter les manipulations intempestives). Idem lors de le fermeture. Les données relatives aux soins peuvent ainsi être travaillées de façon partagées depuis les fichier-outils debrief.

Ce système marche bien mais les modifications de données et les entrées de nouvelles données sont assez longues : entre 5 et 10 secondes.

CE QUE J'AI FAIT POUR L'HEURE :

- J'ai mis en place pour chaque manip' les commandes de désactivation de rafraichissements de l'écran, les calculs en mode manuel, etc.

- Lors de chaque action également j'active l'onglet concerné du fichier DEBRIEF_BASE qui va recevoir l'info : d'après mes essais c'est ce qu'il y a de mieux à faire.

... et puis... après diverses recherches et tentatives je n'ai pas trouvé mieux à faire...

Pour autant, certains parmi vous sauraient peut-être ce qui peut être amélioré dans mon code...

Voici pour exemple le code pour l'ajout d'un nouvel animal :

Option Explicit
Dim ws As Worksheet
Dim Ligne As Long
Public wbt As Workbook
Public wba As Workbook
Public wb As Workbook
Public feuilactive As String 'pour revenir à l'onglet d'où a été activé le bouton de lancement du formulaire

'Pour le formulaire
Private Sub userform_initialize()

TestFichierOuvert

   ThisWorkbook.Activate
     With ThisWorkbook.Windows(1)
   .Visible = True
   End With

    Dim J As Long
    Dim i As Integer

    feuilactive = ActiveSheet.Name  'pour revenir à l'onglet d'où a été activé le bouton de lancement du formulaire
            Set wba = Workbooks("DEBRIEF_BASE_NE_PAS_TOUCHER.xlsx")
          Set wbt = ThisWorkbook

    ComboBox2.ColumnCount = 1 'Pour la liste déroulante secteurs
    ComboBox2.List = wbt.Worksheets("Paramètres").Range("E8:E16").Value

    TextBox4.Value = DateValue(Now)
    TextBox2.Value = Format(Now, "yyyy")

    OptionButton4.Value = True

        End Sub

'Pour le bouton Nouveau contact
Private Sub CommandButton1_Click()

' code pour désactiver des fonctions qui ralentissent l'execution de la macro
With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual

    End With

            Set wba = Workbooks("DEBRIEF_BASE_NE_PAS_TOUCHER.xlsx")
          Set wbt = ThisWorkbook

          Windows("DEBRIEF_BASE_NE_PAS_TOUCHER.xlsx").Activate
    'ActiveWindow.Visible = False

    Set ws = wba.Worksheets("LISTE ANIMAUX") 'Correspond au nom de votre onglet dans le fichier Excel

'Code pour éviter l'entrée de doublon

Dim i As Integer 'Declaration de ma variable

' wba.Save

With ws
 ws.Activate
'On fait le traitement de la cellule A2 jusqu'à la derniere cellule non vide de la colonne A
 For i = 2 To .Range("A65500").End(xlUp).Row
 'Si la cellule courante est égale à la valeur entrée dans ma TextBox
      If .Range("A" & i).Value = TextBox1.Value & " (" & TextBox2.Value & ")" Then
 'Si la reponse au message est oui je poursuis mon traitement
            MsgBox ("ATTENTION ! Ce numéro est déjà attribué ! C'est strictement interdit (art. 342b du code de procédure du debrief)")
        Exit Sub
       End If
    Next

    End With

'If MsgBox("Confirmer nouvel animal ?", vbYesNo, "Demande de confirmation d'ajout") = vbYes Then

If TextBox1 = "" Then
   MsgBox ("ATTENTION !! Vous n'avez pas attribué de  numéro, ça craint !! En cas de doute, attribuez le numéro 3000 et vous le modifierez plus tard...")
Exit Sub
End If

If ComboBox2 = "" Then
  MsgBox ("ATTENTION !! Vous n'avez pas attribué de SECTEUR.")

End If

If TextBox3 = "" Then
    MsgBox ("ATTENTION !! Vous n'avez pas attribué d'ESPECE.")
End If

If TextBox11 = "" Then
    MsgBox ("ATTENTION !! Vous n'avez pas attribué de DATE D'INFO.")

End If

If TextBox4 <> "" And Not IsDate(Me.TextBox4.Value) Then
    MsgBox ("Grrrrrr, il faut entrer une date d'arrivée valide au format jj/mm/aaaa ! (c'est obligatoire) ")

End If

If Not IsDate(Me.TextBox11.Value) And TextBox11 <> "" Then
    MsgBox ("Grrrrrr, il faut entrer une date d'INFO valide au format jj/mm/aaaa ! (c'est obligatoire)")
    Exit Sub
End If

  If MsgBox("Confirmer nouvel animal ?", vbYesNo, "Demande de confirmation d'ajout") = vbYes Then

'Workbooks.Open ("D:\OneDrive\TICHO\debrief en 3\DEBRIEF_BASE_NE_PAS_TOUCHER.xlsx")

       'Windows("DEBRIEF_BASE_NE_PAS_TOUCHER.xlsx").Activate

'With ws
       'Set ws = wba.Worksheets("LISTE ANIMAUX") 'Correspond au nom de votre onglet dans le fichier Excel

'ws.Activate
'ouvrir une première ligne de tableau vierge
ws.Range("2:2").Insert CopyOrigin:=xlFormatFromRightOrBelow
'Incrémenter les données de la 2nde ligne sur la première
ws.Range("S3:BU3").Select
    Selection.AutoFill Destination:=Range("S2:BU3"), Type:=xlFillDefault
ws.Range("S2:BU3").Select

'copie les données du formulaire dans le tableau
        TextBox2.Value = Format(TextBox4.Value, "yyyy")
        ws.Range("A2").Value = TextBox1.Value & " (" & TextBox2.Value & ")" 'numéro complet
        ws.Range("B2").Value = ComboBox2  'secteur
        ws.Range("C2").Value = TextBox12   'sous-secteur
        ws.Range("D2").Value = TextBox1 'numéro
        ws.Range("E2").Value = TextBox2.Value   'Année
        ws.Range("F2").Value = TextBox3   'espèce
        ws.Range("G2").Value = TextBox5   'Diag
        ws.Range("H2").Value = TextBox6   'POids
        ws.Range("I2").Value = TextBox7   'Traitement
        ws.Range("J2").Value = TextBox8   'nourrissage
        ws.Range("K2").Value = TextBox9   'Observations
        ws.Range("L2").Value = TextBox11  'date info
        ws.Range("M2").Value = TextBox4   'date arrivée
        ws.Range("N2").Value = TextBox10  'Historique

         'ws.Range("S2").Value = "=LIGNE()"  'Historique
       ' ws.Range("T2").Value =

       'pour point relaché :

           'Dim Ligne As Long
 ' With ws
 'ws.Activate

       If OptionButton1 = True Then
        ws.Range("O2").Value = 1
        ws.Range("K2").Value = TextBox9 & Chr(13) & Chr(10) & "---" & Chr(13) & Chr(10) & "PR : à faire > Mi"
       End If

       If OptionButton2 = True Then
         ws.Range("O2").Value = 2
         ws.Range("K2").Value = TextBox9 & Chr(13) & Chr(10) & "---" & Chr(13) & Chr(10) & "PR : Vu, OK. Orga > Mi"
       End If

       'If OptionButton3 = True Then
     '    .Range("O2").Value = 3
     '    .Range("K2").Value = TextBox9 & Chr(13) & Chr(10) & "---" & Chr(13) & Chr(10) & "PR : Vu. Pas relachable"
    '   End If

      'pour Situation :

                     'Windows("DEBRIEF_BASE_NE_PAS_TOUCHER.xlsx").Activate

'With ws
       'Set ws = wba.Worksheets("LISTE ANIMAUX") 'Correspond au nom de votre onglet dans le fichier Excel

'ws.Activate
       If OptionButton4 = True Then
        ws.Cells(2, "P") = "En soin"
       End If

       If OptionButton5 = True Then
        'ws.Range("P2").Value = "Relâché" And ws.Range("O2").Value = ""
         ws.Cells(2, "P") = "Relâché"
        ws.Cells(2, "O") = ""
        End If

       If OptionButton6 = True Then
         ws.Cells(2, "P") = "Mort"
       End If

       If OptionButton7 = True Then
        ws.Cells(2, "P") = "Echappé"
       End If

           'ws.Range("F1").Select

    ' End With

'Sheets("TOUS Animaux").Activate
'ActiveSheet.Unprotect ("TICHO2020")
 '   Rows("3:3").Select
  '  Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
   ' Range("A4:J4").Select
    'Selection.AutoFill Destination:=Range("A3:J4"), Type:=xlFillDefault
   ' Range("A3:J4").Select
    'Rows("3:3").EntireRow.AutoFit
  '  Range("L3:Q3").Select

'    With Selection.Interior
 '      .Pattern = xlNone
  '     .TintAndShade = 0
   '    .PatternTintAndShade = 0
  '  End With

   '  ActiveSheet.Protect ("TICHO2020")

    ' Range("F1").Select

  'Pour enregistrement dans ONGLET ARCHIVES

        Set ws = Nothing

       Windows("DEBRIEF_BASE_NE_PAS_TOUCHER.xlsx").Activate

        With Sheets("Archives")

Sheets("Archives").Activate
'ActiveSheet.Unprotect ("TICHO2020")
'ouvrir une première ligne de tableau vierge
Range("5:5").Insert CopyOrigin:=xlFormatFromRightOrBelow
'Incrémenter les données de la 2nde ligne sur la première
    Range("A6:V6").Select
    Selection.AutoFill Destination:=Range("A5:V6"), Type:=xlFillDefault
    Range("A5:V6").Select

'copie les données du formulaire dans l'ONGLET ARCHIVES
        TextBox2.Value = Format(TextBox4.Value, "yyyy")
        .Range("A5").Value = TextBox1.Value & " (" & TextBox2.Value & ")"  ' Numéro complet
        .Range("B5").Value = ComboBox2  'Secteur
        .Range("C5").Value = TextBox12  'sous-secteur
        .Range("D5").Value = TextBox1  ' Numéro
        .Range("E5").Value = Format(TextBox4.Value, "yyyy")   'Année
        .Range("F5").Value = TextBox3   'Espèce
        .Range("G5").Value = TextBox5   'diag
        .Range("H5").Value = TextBox6   'Poids
        .Range("I5").Value = TextBox7   'nourrissage
        .Range("J5").Value = TextBox8   'traitement
        .Range("K5").Value = TextBox9   'observations
        .Range("L5").Value = TextBox11   'date info
        .Range("M5").Value = TextBox4  'Date d'arrivée
        .Range("N5").Value = TextBox10  ' historique

     End With

     ActiveWorkbook.Save
     'ActiveWorkbook.RefreshAll
     'ActiveWindow.Visible = False

 'ActiveSheet.Protect ("TICHO2020")

'pour revenir au formulaire si on ne confirme pas l'ajout de l'animal
Else
Exit Sub

    End If

  ComboBox2.Value = ""
TextBox1.Value = ""
TextBox2.Value = Format(Now, "yyyy")
TextBox3.Value = ""
TextBox5.Value = ""
TextBox6.Value = ""
TextBox7.Value = ""
TextBox8.Value = ""
TextBox9.Value = ""
TextBox11.Value = ""
TextBox12.Value = ""
TextBox10.Value = ""
TextBox4.Value = DateValue(Now)

        wbt.Activate 'pour revenir à l'onglet d'où a été activé le bouton de lancement du formulaire
          ActiveWindow.Visible = True
          Sheets(feuilactive).Activate 'pour revenir à l'onglet d'où a été activé le bouton de lancement du formulaire

     Unload Me

final:

     ' code pour résactiver des fonctions désactivées en début de marcos parce qu'elles ralentissent l'execution de la macro
     With Application

    Application.ScreenUpdating = True 'arrête le travail en arrière plan
    Application.DisplayStatusBar = True 'inhibe la mise a jour de la barre d'état
    Application.Calculation = xlCalculationAutomatic 'le mode de calcul devient manuel

End With

MiseEnPageTsAni

End Sub

'Pour le bouton Date du jour dans info
Private Sub CommandButton4_Click()
    TextBox11.Value = DateValue(Now)
End Sub

'Pour le bouton Quitter
Private Sub CommandButton3_Click()
    Unload Me
End Sub

Mon fichier fait plus de 1,5 Mo je ne peux pas vous le joindre... je vais essayer d'arranger ça.

Un idée en attendant ?

merci !

Delphine.

Le 04/07/2021 à 23:24

Bonjour,

une tentative.
Sans fichier tu te doutes bien qu'il est impossible de tester quoique ce soit... Donc travaille sur une copie

J'ai accéléré 2 partie.
1) remplacement d'une boucle chronophage par une recherche
2) écriture d'un tableau en une fois plutôt que de multiples écritures chronophages également
Plus bas tu as une autre série d'écritures à faire sur le même modèle.

Ceci dit, il va rester les éventuels problèmes de lenteur réseau.
Si tu en as, excel n'y peut rien. Il faudra voir avec le responsable du SI

L'ancien code est mis 3 fois en commentaire avec ''', le nouveau est entre des '********************************

Option Explicit

Dim ws As Worksheet
Dim Ligne As Long
Public wbt As Workbook
Public wba As Workbook
Public wb As Workbook
Public feuilactive As Worksheet 'pour revenir à l'onglet d'où a été activé le bouton de lancement du formulaire

'Pour le formulaire
Private Sub userform_initialize()

    TestFichierOuvert

    ThisWorkbook.Activate
    With ThisWorkbook.Windows(1)
        .Visible = True
    End With

    Dim J As Long
    Dim i As Integer

    feuilactive = ActiveSheet  'pour revenir à l'onglet d'où a été activé le bouton de lancement du formulaire
    Set wba = Workbooks("DEBRIEF_BASE_NE_PAS_TOUCHER.xlsx")
    Set wbt = ThisWorkbook

    ComboBox2.ColumnCount = 1 'Pour la liste déroulante secteurs
    ComboBox2.List = wbt.Worksheets("Paramètres").Range("E8:E16").Value

    TextBox4.Value = DateValue(Now)
    TextBox2.Value = Format(Now, "yyyy")

    OptionButton4.Value = True

End Sub

'Pour le bouton Nouveau contact
Private Sub CommandButton1_Click()
    Dim c As Range, tabl() As Variant
    ' code pour désactiver des fonctions qui ralentissent l'execution de la macro
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual

    End With

    Set wba = Workbooks("DEBRIEF_BASE_NE_PAS_TOUCHER.xlsx")
    Set wbt = ThisWorkbook

    Windows("DEBRIEF_BASE_NE_PAS_TOUCHER.xlsx").Activate
    'ActiveWindow.Visible = False

    Set ws = wba.Worksheets("LISTE ANIMAUX") 'Correspond au nom de votre onglet dans le fichier Excel

    'Code pour éviter l'entrée de doublon

    Dim i As Integer 'Declaration de ma variable

    ' wba.Save

    With ws
        ws.Activate
        'On fait le traitement de la cellule A2 jusqu'à la derniere cellule non vide de la colonne A
        '''        For i = 2 To .Range("A65500").End(xlUp).Row
        '''            'Si la cellule courante est égale à la valeur entrée dans ma TextBox
        '''            If .Range("A" & i).Value = TextBox1.Value & " (" & TextBox2.Value & ")" Then
        '''                'Si la reponse au message est oui je poursuis mon traitement
        '''                MsgBox ("ATTENTION ! Ce numéro est déjà attribué ! C'est strictement interdit (art. 342b du code de procédure du debrief)")
        '''                Exit Sub
        '''            End If
        '''        Next

        '***************************************
        ' !!! recherche au lieu d'une boucle sur toutes les cellules !!!
        Set c = .Columns(1).Find(TextBox1.Value & " (" & TextBox2.Value & ")", , xlValues, xlWhole)
        If Not c Is Nothing Then
            MsgBox ("ATTENTION ! Ce numéro est déjà attribué ! C'est strictement interdit (art. 342b du code de procédure du debrief)")
            Exit Sub
        End If
        '*******************************************
    End With

    'If MsgBox("Confirmer nouvel animal ?", vbYesNo, "Demande de confirmation d'ajout") = vbYes Then

    If TextBox1 = "" Then
        MsgBox ("ATTENTION !! Vous n'avez pas attribué de  numéro, ça craint !! En cas de doute, attribuez le numéro 3000 et vous le modifierez plus tard...")
        Exit Sub
    End If

    If ComboBox2 = "" Then
        MsgBox ("ATTENTION !! Vous n'avez pas attribué de SECTEUR.")

    End If

    If TextBox3 = "" Then
        MsgBox ("ATTENTION !! Vous n'avez pas attribué d'ESPECE.")
    End If

    If TextBox11 = "" Then
        MsgBox ("ATTENTION !! Vous n'avez pas attribué de DATE D'INFO.")

    End If

    If TextBox4 <> "" And Not IsDate(Me.TextBox4.Value) Then
        MsgBox ("Grrrrrr, il faut entrer une date d'arrivée valide au format jj/mm/aaaa ! (c'est obligatoire) ")

    End If

    If Not IsDate(Me.TextBox11.Value) And TextBox11 <> "" Then
        MsgBox ("Grrrrrr, il faut entrer une date d'INFO valide au format jj/mm/aaaa ! (c'est obligatoire)")
        Exit Sub
    End If

    If MsgBox("Confirmer nouvel animal ?", vbYesNo, "Demande de confirmation d'ajout") = vbYes Then

        'Workbooks.Open ("D:\OneDrive\TICHO\debrief en 3\DEBRIEF_BASE_NE_PAS_TOUCHER.xlsx")

        'Windows("DEBRIEF_BASE_NE_PAS_TOUCHER.xlsx").Activate

        'With ws
        'Set ws = wba.Worksheets("LISTE ANIMAUX") 'Correspond au nom de votre onglet dans le fichier Excel

        'ws.Activate
        'ouvrir une première ligne de tableau vierge
        ws.Range("2:2").Insert CopyOrigin:=xlFormatFromRightOrBelow
        'Incrémenter les données de la 2nde ligne sur la première
        ws.Range("S3:BU3").Select
        Selection.AutoFill Destination:=Range("S2:BU3"), Type:=xlFillDefault
        ws.Range("S2:BU3").Select

        'copie les données du formulaire dans le tableau
        TextBox2.Value = Format(TextBox4.Value, "yyyy")
        '''        ws.Range("A2").Value = TextBox1.Value & " (" & TextBox2.Value & ")" 'numéro complet
        '''        ws.Range("B2").Value = ComboBox2  'secteur
        '''        ws.Range("C2").Value = TextBox12   'sous-secteur
        '''        ws.Range("D2").Value = TextBox1 'numéro
        '''        ws.Range("E2").Value = TextBox2.Value   'Année
        '''        ws.Range("F2").Value = TextBox3   'espèce
        '''        ws.Range("G2").Value = TextBox5   'Diag
        '''        ws.Range("H2").Value = TextBox6   'POids
        '''        ws.Range("I2").Value = TextBox7   'Traitement
        '''        ws.Range("J2").Value = TextBox8   'nourrissage
        '''        ws.Range("K2").Value = TextBox9   'Observations
        '''        ws.Range("L2").Value = TextBox11  'date info
        '''        ws.Range("M2").Value = TextBox4   'date arrivée
        '''        ws.Range("N2").Value = TextBox10  'Historique

        '**************************
        ' on remplit un tableau qui sera écrit en 1 fois
        ReDim tabl(1 To 1, 1 To 14)
        tabl(1, 1) = TextBox1.Value & " (" & TextBox2.Value & ")" 'numéro complet
        tabl(1, 2) = ComboBox2  'secteur
        tabl(1, 3) = TextBox12   'sous-secteur
        tabl(1, 4) = TextBox1 'numéro
        tabl(1, 5) = TextBox2.Value   'Année
        tabl(1, 6) = TextBox3   'espèce
        tabl(1, 7) = TextBox5   'Diag
        tabl(1, 8) = TextBox6   'POids
        tabl(1, 9) = TextBox7   'Traitement
        tabl(1, 10) = TextBox8   'nourrissage
        tabl(1, 11) = TextBox9   'Observations
        tabl(1, 12) = TextBox11  'date info
        tabl(1, 13) = TextBox4   'date arrivée
        tabl(1, 14) = TextBox10  'Historique
        ws.Range("A2:N2") = tabl
        '*********************************

        'ws.Range("S2").Value = "=LIGNE()"  'Historique
        ' ws.Range("T2").Value =

        'pour point relaché :

        'Dim Ligne As Long
        ' With ws
        'ws.Activate

        If OptionButton1 = True Then
            ws.Range("O2").Value = 1
            ws.Range("K2").Value = TextBox9 & Chr(13) & Chr(10) & "---" & Chr(13) & Chr(10) & "PR : à faire > Mi"
        End If

        If OptionButton2 = True Then
            ws.Range("O2").Value = 2
            ws.Range("K2").Value = TextBox9 & Chr(13) & Chr(10) & "---" & Chr(13) & Chr(10) & "PR : Vu, OK. Orga > Mi"
        End If

        'If OptionButton3 = True Then
        '    .Range("O2").Value = 3
        '    .Range("K2").Value = TextBox9 & Chr(13) & Chr(10) & "---" & Chr(13) & Chr(10) & "PR : Vu. Pas relachable"
        '   End If

        'pour Situation :

        'Windows("DEBRIEF_BASE_NE_PAS_TOUCHER.xlsx").Activate

        'With ws
        'Set ws = wba.Worksheets("LISTE ANIMAUX") 'Correspond au nom de votre onglet dans le fichier Excel

        'ws.Activate
        If OptionButton4 = True Then
            ws.Cells(2, "P") = "En soin"
        End If

        If OptionButton5 = True Then
            'ws.Range("P2").Value = "Relâché" And ws.Range("O2").Value = ""
            ws.Cells(2, "P") = "Relâché"
            ws.Cells(2, "O") = ""
        End If

        If OptionButton6 = True Then
            ws.Cells(2, "P") = "Mort"
        End If

        If OptionButton7 = True Then
            ws.Cells(2, "P") = "Echappé"
        End If

        'ws.Range("F1").Select

        ' End With

        'Sheets("TOUS Animaux").Activate
        'ActiveSheet.Unprotect ("TICHO2020")
        '   Rows("3:3").Select
        '  Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        ' Range("A4:J4").Select
        'Selection.AutoFill Destination:=Range("A3:J4"), Type:=xlFillDefault
        ' Range("A3:J4").Select
        'Rows("3:3").EntireRow.AutoFit
        '  Range("L3:Q3").Select

        '    With Selection.Interior
        '      .Pattern = xlNone
        '     .TintAndShade = 0
        '    .PatternTintAndShade = 0
        '  End With

        '  ActiveSheet.Protect ("TICHO2020")

        ' Range("F1").Select

        'Pour enregistrement dans ONGLET ARCHIVES

        Set ws = Nothing

        Windows("DEBRIEF_BASE_NE_PAS_TOUCHER.xlsx").Activate

        With Sheets("Archives")

            Sheets("Archives").Activate
            'ActiveSheet.Unprotect ("TICHO2020")
            'ouvrir une première ligne de tableau vierge
            Range("5:5").Insert CopyOrigin:=xlFormatFromRightOrBelow
            'Incrémenter les données de la 2nde ligne sur la première
            Range("A6:V6").Select
            Selection.AutoFill Destination:=Range("A5:V6"), Type:=xlFillDefault
            Range("A5:V6").Select

            'copie les données du formulaire dans l'ONGLET ARCHIVES
            TextBox2.Value = Format(TextBox4.Value, "yyyy")
            .Range("A5").Value = TextBox1.Value & " (" & TextBox2.Value & ")"  ' Numéro complet
            .Range("B5").Value = ComboBox2  'Secteur
            .Range("C5").Value = TextBox12  'sous-secteur
            .Range("D5").Value = TextBox1  ' Numéro
            .Range("E5").Value = Format(TextBox4.Value, "yyyy")   'Année
            .Range("F5").Value = TextBox3   'Espèce
            .Range("G5").Value = TextBox5   'diag
            .Range("H5").Value = TextBox6   'Poids
            .Range("I5").Value = TextBox7   'nourrissage
            .Range("J5").Value = TextBox8   'traitement
            .Range("K5").Value = TextBox9   'observations
            .Range("L5").Value = TextBox11   'date info
            .Range("M5").Value = TextBox4  'Date d'arrivée
            .Range("N5").Value = TextBox10  ' historique

        End With

        ActiveWorkbook.Save
        'ActiveWorkbook.RefreshAll
        'ActiveWindow.Visible = False

        'ActiveSheet.Protect ("TICHO2020")

        'pour revenir au formulaire si on ne confirme pas l'ajout de l'animal
    Else
        Exit Sub

    End If

    ComboBox2.Value = ""
    TextBox1.Value = ""
    TextBox2.Value = Format(Now, "yyyy")
    TextBox3.Value = ""
    TextBox5.Value = ""
    TextBox6.Value = ""
    TextBox7.Value = ""
    TextBox8.Value = ""
    TextBox9.Value = ""
    TextBox11.Value = ""
    TextBox12.Value = ""
    TextBox10.Value = ""
    TextBox4.Value = DateValue(Now)

    wbt.Activate 'pour revenir à l'onglet d'où a été activé le bouton de lancement du formulaire
    ActiveWindow.Visible = True
    feuilactive.Activate 'pour revenir à l'onglet d'où a été activé le bouton de lancement du formulaire

    Unload Me

final:

    ' code pour résactiver des fonctions désactivées en début de marcos parce qu'elles ralentissent l'execution de la macro
    With Application

        Application.ScreenUpdating = True 'arrête le travail en arrière plan
        Application.DisplayStatusBar = True 'inhibe la mise a jour de la barre d'état
        Application.Calculation = xlCalculationAutomatic 'le mode de calcul devient manuel

    End With

    MiseEnPageTsAni

End Sub

eric

Le 05/07/2021 à 16:51

Bonjour Eric,

Grand merci pour cette proposition que j'ai commencé à mettre en place dans mes différents userform.

Ce n'est pas encore supersonique mais je gagne du temps, effectivement !

...en plus j'apprends à décliner aussi ces formules ce qui est bien intéressant.

... en plus je constate qu'un code propre et bien présenté est plus agréable à travailler (bon, je m'en doutais mais au milieu de mon chantier je n'avais pas trio fait d'effort.)

Je verrais quand j'en aurais fini avec ces modifs si je relance un post pour voir si on peut aller plus loin.

Encore merci !!

Delphine

Rechercher des sujets similaires à "accelerer procedures dispositif fichiers lies"