VBA améliorer vitesse pour inscription dans un tableau

Bonjour,

J'ai créé un formulaire de saisie afin de documenter le tableau2 commençant à la la cellule A1.

Dans les informations à compléter, il y a la date de début et la date de fin. Mon objectif est qu'une ligne se crée pour chaque jour entre ces dates. Ex si 1er septembre au 4 septembre, on aura 4 nouvelles lignes. J'ai trouvé une façon qui était de calculer dans la colonne j le nombre de jour entre ces dates, et ensuite d'insérer des lignes selon ce nombre.

Cependant le calcul m'apparaît un peu long sur mon tableau test avec peu de données. Je crains que quand il y aura beaucoup de données ca devienne trop long. Je vous soumets mon code, pourriez vous svp m'indiquer comment je pourrais l'optimiser?

MERCI BEAUCOUP!

Private Sub CommandButton1_Click()

Application.ScreenUpdating = False

'Valider un nom
If ComboBoxNom = "" Then
 MsgBox "veuillez Inscrire un nom", vbOKOnly + vbInformation, "VALIDATION"
    Exit Sub
  End If

       ' Valider un motif
       If ComboBoxMotif = "" Then
 MsgBox "veuillez Inscrire un motif", vbOKOnly + vbInformation, "VALIDATION"
        Exit Sub
       End If

' Valider les formats de date
Dim jour, année, mois
    If IsDate(TextBoxDateDebut) Then
        jour = Day(TextBoxDateDebut): mois = Month(TextBoxDateDebut): année = Year(TextBoxDateDebut):
            Else
        MsgBox "veuillez valider la date de début", vbOKOnly + vbInformation, "VALIDATION"
        Exit Sub
             End If

   If TextBoxDateFin <> "" Then
    Dim jourf, annéef, moisf
   If IsDate(TextBoxDateFin) Then
        jourf = Day(TextBoxDateFin): moisf = Month(TextBoxDateFin): annéef = Year(TextBoxDateFin):
            Else
        MsgBox "veuillez valider la date de fin", vbOKOnly + vbInformation, "VALIDATION"
       Exit Sub

            End If
            End If

    '
    'transcrire infos

Sheets("Données").Rows("6:6").Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets("Données").Range("b6") = ComboBoxNom
Sheets("Données").Range("q6") = ComboBoxMotif
Sheets("Données").Range("f6") = CDate(TextBoxDateDebut)
Sheets("Données").Range("t6") = TextBoxCommentaires
Sheets("Données").Range("a6") = ComboBoxStatut

'si aucune date de fin, inscrire date de début par défaut
If TextBoxDateFin <> "" Then
Sheets("Données").Range("g6") = CDate(TextBoxDateFin)
Else
Sheets("Données").Range("g6") = CDate(TextBoxDateDebut)
End If
'
'1/2 journée

If CheckBoxam Then
Sheets("Données").Range("s6").Value = -0.5
End If
'

'
'tout afficher

On Error Resume Next
With Sheets("Données")
.Activate
  ActiveSheet.ListObjects("Tableau2").Range.AutoFilter
End With

'insérer les lignes selon nombre de jours
  Dim i As Integer
i = Range("j6").Value
If i > 0 Then

 Rows("7:" & "7" + i).Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

 '
 'Copie info de la ligne 6 sur les autres

 Rows("6:6").Copy
    Rows("7:" & "7" + i).Select
    ActiveSheet.Paste
    '
 'ajoute +1 à chaque date

 Range("f7").Select
        ActiveCell.FormulaR1C1 = "=R[-1]C+1"

    '
    Rows("7:7").Copy
    Rows("7:" & "7" + i).Select
    ActiveSheet.Paste
    '

   'copie pour effacer formule date
   Range("f:f").Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

  End If

'

'
   ActiveWorkbook.Worksheets("Données").ListObjects("Tableau2").Sort.SortFields. _
        Clear
    ActiveWorkbook.Worksheets("Données").ListObjects("Tableau2").Sort.SortFields. _
        Add2 Key:=Range("Tableau2[[#All],[Date]]"), SortOn:=xlSortOnValues, Order _
        :=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Données").ListObjects("Tableau2").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveSheet.ListObjects("Tableau2").Range.AutoFilter Field:=2, Criteria1:= _
        ComboBoxNom

Application.ScreenUpdating = True
Unload Me

End Sub

Bonjour

Cordialement

J'ajoute le fichier en question, merci! :)

Bonjour Jujule, bonjour Dan,

La macro est en soi déjà complexe à comprendre. Mais ce n'est pas le plus chronophage. Ce sont les formules du tableau qu'il faut retravailler en priorité.

• formules RECHERCHEV en colonnes C et D, si les fonctions sont figées (au moins au moment de l'inscription) il faut absorber le tableau TableauEmployés et inscrire en dur les données des colonnes C et D.
• Ensuite, je n'ai pas compris la fonction de la colonne H qui est aussi chronophage. Est-il possible de la lier simplement à la colonne G ? Si je comprends bien, TableauJours est inutile et à remplacer par la formule =____ladate____ avec format jjjj et en tenir compte dans la formule colonne S avec joursem(____;2)>5 pour identifier les jours du week end
• idem colonne M, ne pas appeler un tableau annexe, c'est inutile, un format mmmm suffit
• colonne P : erreur sur la formule qui te donnera un résultat faux dès l'an prochain, il faut utiliser no.semaine.iso
• Enfin, colonne U, c'est le plus lourd ... à faire une seule fois lors de la mise en place d'une nouvelle ligne, par absorption dans un array du Tableau2

Il faut aussi indenter correctement un code pour y voir clair ... ce que j'essaierai de faire demain matin en te proposant une correction sur le premier et le dernier alinéa de mes remarques - le reste est fait (sauf si qqun a repris la main sur le sujet).

Dans le code, tu sors par exit sub en ayant marqué au préalable Application.ScreenUpdating = False, ta feuille restera bloqué !

Votre fichier en retour pour test

Je ne pense pas que cela va ralentir mais par contre deux remarques
- J'ai supprimé le Rowssource dans votre userform --> J'évite toujours cette instruction qui pose des soucis quelque fois
- Pourquoi déchargez vous l'Userfom une fois que vous valider ? Vous pourriez vider les rubrique tout simplement
- dans la feuille Source votre tableau employé pourrait être juste adapté pour ne pas avoir toutes ces lignes vides.

Edit : avec le fichier c'est mieux

A noter que tes macro réduire et Afficher pourrait être simplifié. Enlève le Scroll.... et les select, selection

Au fait, il y a des liaisons dans le fichier. Elles servent à quelque chose ? cela peut ralentir aussi cela.

Parfait, je n'ai plus rien à faire sur la macro, sauf à résoudre le problème des formules des colonnes C, D et U qui sont chronophages. A voir si tu ressens toujours une lenteur.

Tant qu'à faire... Voici les deux macros Réduire et Afficher

Sub Afficher()
Columns("A:V").EntireColumn.Hidden = False
End Sub

Sub Réduire()
Range("E:E,G:G,I:P,R:R").EntireColumn.Hidden = True
End Sub

Au fait, il y a des liaisons dans le fichier. Elles servent à quelque chose ? cela peut ralentir aussi cela.

Reste les formules dont s'occupe Steelson.

Wow

Merci beaucoup! Je suis impressionnée.. Je suis débutante en VBA, et j'adore ce monde que je découvre.

J'avais un fichier initial plus fourni avec des protections pour mot de passe notamment, mais que j'ai réduit à ce que je croyais être le cœur du problème. Aucune liaison avec des fichiers externes n'est nécessaire. C'est un résiduel d'une copie de formule.

Je regarde le tout plus en profondeur sous peu.

Merci encore!

En complément de l'excellent travail de Dan,

• colonne F : =NO.SEMAINE.ISO([@Date])
• colonne U : si c'est toujours ralenti, supprime la formule et compare, c'est elle qui prend 80% du temps de traitement. On pourra proposer quelque chose, soit par macro, soit par TCD qui a l'avantage de ne faire le calcul qu'une seule fois en bloc

Le reste des formules est plus secondaire, je verrai cela demain.

Dan : les formules externes, je pense qu'elles sont liées à un copier/coller de fichier, mais elles sont en réalité interne au Tableau2.

Bonsoir Steelson et Dan,

Encore une fois énorme merci :)

J'ai tout revu, j'aime beaucoup la simplification que vous avez apporté. J'ai donc allégé mon tableau pour supprimer le superflu pour donner ceci. J'ai laissé également les autres feuilles pour valider que rien ne vient en interférence, quoique les délais étaient présents avant les ajouts. J'ai modifié pour que les mots de passe soient tous à "password"). Il n'y a également plus de liaisons externes.

Je constate que le délai semble encore long malgré le fait que j'ai supprimé la colonne des doublons (qui sera également essentielle et j'aurais besoin d'aide pour trouver une alternative pour souligner les doublons lorsque deux lignes ont les mêmes données pour la colonne Nom et Date ).

J'ai également testé en enlevant les recherches v et le délai semble s'améliorer. Je n'ai pas bien compris quoi faire pour améliorer les recherchev ? qui sont maintenant les colonnes C, D et O. Le tableau des employés contient le nombre de lignes des employés réels, que j'avais effacé sur le premier fichier envoyé.

Est ce que ce délai peut être occasionné par le fait que les colonnes sont insérées au début du tableau et non à la fin?

Merci pour votre temps qui est grandement apprécié

Est-ce que je demande trop si je demande de l'aide pour qu'un courriel outlook soit envoyé automatiquement à chaque nouvelle entrée ayant comme statut "nouvelle demande" ? (à chaque nouvelle entrée de formulaire, pas pour chaque date) C'était ma prochaine étape, mais avant de m'y lancer je voulais m'assurer que ma base était bonne.

Edit: Finalement voici le fichier modifier avec la fonction d'email que j'ai trouvée et qui semble fonctionnelle, j'aurais juste aimé indiquer en plus le contenu de la ligne dans le texte

Jujule a écrit :

Je constate que le délai semble encore long malgré le fait que j'ai supprimé la colonne des doublons (qui sera également essentielle et j'aurais besoin d'aide pour trouver une alternative pour souligner les doublons lorsque deux lignes ont les mêmes données pour la colonne Nom et Date ).

J'ai également testé en enlevant les recherches v et le délai semble s'améliorer. Je n'ai pas bien compris quoi faire pour améliorer les recherchev ? qui sont maintenant les colonnes C, D et O. Le tableau des employés contient le nombre de lignes des employés réels, que j'avais effacé sur le premier fichier envoyé.

Bonjour,

je suis un peu largué par la nouvelles mouture, quoiqu'il en soit, voici ce que je préparais en parallèle, notamment pour les RECHERCHEV et la détection des doublons

compléments :

• colonne H, tu peux éviter RECHERCHEV avec le paramètre FAUX qui va balayer toutes les valeurs séquentiellement (on aurait pu mettre VRAI ici avec le même résultat et dans ce cas excel fait une recherche plus rapide par dichotomie), mais sans tout chambouler, tu peux aussi utiliser la formule =NOMPROPRE(TEXTE([@Date];"jjjj"))
• colonne M : idem =TEXTE([@Date];"mmmm")
• pour la colonne U :
  • soit on fait un TCD qui a l'avantage de calculer en une seule fois, mais n'apparaît pas directement sur le tableau, on oublie
  • soit au niveau de la macro tu ajoutes la méthode de calcul Application.Calculation = xlCalculationManual et ensuite tu finis avec Application.Calculation = xlCalculationAutomatic mais ce n'est pas compatible avec la formule insérée dans la macro, donc on oublie
  • soit tu y mets juste la comparaison avec la ligne précédente =ET([@Nom]=DECALER([@Nom];-1;);[@Date]=DECALER([@Date];-1;)) puisque de toute façon tu finis par trier par date, et bien sûr tu ajoutes aussi le tri par nom dans la macro
• au passage je modifie aussi la MFC pour tenir compte de la nouvelle formule, mais aussi pour l'appliquer sur toute la colonne, pourquoi ? car les MFC ont tendance à se multiplier à l'infini et entraver sérieusement aussi le temps de traitement (donc efface les aussi sur ton document original avant de mettre la nouvelle sur tout U)

voici avec quelques corrections proposées de formules (désolé c'est l'ancien fichier)

Pour moi il y a encore d'autres pistes au niveau logigramme

• ne pas insérer des lignes dans le tableau qui fait faire à excel une gymnastique de décalage de tout un paquet d'informations, mais ajouter les lignes à la fin du tableau ... pas de crainte, pas de risque, les nouvelles lignes d'un tableau héritent automatiquement des formules et formats des autres lignes du tableau
• ne pas mettre la formule d'ajout de 1 dans la date pour ensuite recopier en valeur, mais
  • mettre directement la date incrémentée dans le code VBA,
  • et alors on peut aussi y ajouter la méthode de calcul Application.Calculation = xlCalculationManual et Application.Calculation = xlCalculationAutomatic
• au niveau des autres RECHERCHEV, on peut absorber le tableau des employés dans un array et faire une recherche limitée au seul nom introduit dans l'userform et inscrire en dur la valeur dans la cellule de la feuille, cela demande à retoucher la macro ... dans tous les cas comme le disait Dan il faut supprimer toutes les lignes vides des tableaux

Steelson a écrit :

ne pas insérer des lignes dans le tableau qui fait faire à excel une gymnastique de décalage de tout un paquet d'informations, mais ajouter les lignes à la fin du tableau ... pas de crainte, pas de risque, les nouvelles lignes d'un tableau héritent automatiquement des formules et formats des autres lignes du tableau

ne pas mettre la formule d'ajout de 1 dans la date pour ensuite recopier en valeur, mais

• mettre directement la date incrémentée dans le code VBA,
• et alors on peut aussi y ajouter la méthode de calcul Application.Calculation = xlCalculationManual et Application.Calculation = xlCalculationAutomatic

Pour ceci, j'ai changé cette partie du code

'transcrire infos
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'tout afficher

On Error Resume Next
With Sheets("Données")
    .Activate
    .ListObjects("Tableau2").Range.AutoFilter
End With
On Error GoTo 0

With Sheets("Données")
    der = .Range("B" & Rows.Count).End(xlUp).Row

    'si aucune date de fin, inscrire date de début par défaut
    If TextBoxDateFin <> "" Then
        n = CDate(TextBoxDateFin) - CDate(TextBoxDateDebut)
        .Range("g" & der & ":g" & der + n) = CDate(TextBoxDateFin)
    Else
        .Range("g" & der) = CDate(TextBoxDateDebut)
        n = 0
    End If

    .Range("b" & der & ":b" & der + n) = ComboBoxNom
    .Range("q" & der & ":q" & der + n) = ComboBoxMotif
    .Range("t" & der & ":t" & der + n) = TextBoxCommentaires
    .Range("a" & der & ":a" & der + n) = ComboBoxStatut
    For i = der To der + n
        .Range("f" & i) = CDate(TextBoxDateDebut) + i - der
    Next

    '1/2 journée
    If CheckBoxam Then .Range("s" & der & ":s" & der + n).Value = -0.5

End With

With Worksheets("Données").ListObjects("Tableau2").Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("Tableau2[Date]"), SortOn:=xlSortOnValues, Order:= _
        xlDescending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Range("Tableau2[Nom]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
Worksheets("Données").ListObjects("Tableau2").Range.AutoFilter Field:=2, Criteria1:=ComboBoxNom

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

précision, il faut que le tableau ait déjà une ligne sinon il faut faire ListRows.add

Pour les RECHERCHEV sur le nom (désolé pour le feuilleton, mais in fine c'est plus didactique)

1. tu peux enlever les formules et copier/coller comme valeur les données actuelles
2. j'ajoute en tête de macro Dim tblEmploy
3. je charge le tableau à l'initialisation tblEmploy = .ListObjects("TableauEmployés").DataBodyRange.Value
4. je recherche par dichotomie (nouvelle fonction ajoutée) ... il faut que le tableau soit trié par nom

5. Function dichotomie(valeurcherchee As Variant, tableau) As Double
   ' donne la ligne de la valeur recherchée (0 si pas trouvé)
   Dim deb As Double, fin As Double, milieu As Double
   Dim valeurcourante As Variant
   
       dichotomie = 0
       deb = LBound(tableau)
       fin = UBound(tableau)
       If valeurcherchee = tableau(deb, 1) Then dichotomie = deb: Exit Function
       If valeurcherchee = tableau(fin, 1) Then dichotomie = fin: Exit Function
   
       While deb <> fin - 1
           milieu = Int((deb + fin) / 2)
           valeurcourante = tableau(milieu, 1)
           If valeurcourante = valeurcherchee Then
               dichotomie = milieu
               Exit Function
           Else
               If valeurcourante > valeurcherchee Then
                   fin = milieu
               Else
                   deb = milieu
               End If
           End If
       Wend
   
   End Function

   15copie-de-calendrier-test.xlsm (66.36 Ko)

complément car le post précédent mange mes fonctions ...

    ligne = dichotomie(ComboBoxNom, tblEmploy)

' ...

    .Range("b" & der & ":b" & der + n) = ComboBoxNom
    .Range("c" & der & ":c" & der + n) = tblEmploy(ligne, 2)
    .Range("d" & der & ":d" & der + n) = tblEmploy(ligne, 3)

Dans ta nouvelle mouture que je commence à découvrir ...

=SI([@Statut]="En attente";0;SI([@Motif]="P-Bureau";0;SI([@Motif]="disponible";0;SI([@Motif]="P-Télétravail";0;SI([@[jour semaine]]="Samedi";0;SI([@[jour semaine]]="dimanche";0;SI([@[Nombre de jours]]>1;-1;-[@[Nombre de jours]])))))))

ne marche pas avec la colonne H qui est numérique (le format jjjj n'y fait rien).

Bonjour,

Oulà, vous ne dormez pas...

J'avais fait quelques modifications dans le fichier initial mais comme Steelson s'occupe activement du code également, je le laisse continuer sur ce fil.

Cordialement