Autres Tableau de gestion d'effectif

Domi_49 · 19 Juin 2019

Bonjour,

J'utilise depuis 3 ans un gestionnaire d'effectif qui fonctionne plutôt bien, que vous trouverez en pj dans les 3 onglets en bleu, pour démonstration.

Nous allons avoir un réorganisation en 2 ateliers (au lieu d'un seul aujourd'hui), qui fait que nous devons revoir le fonctionnement du système existant.
J'ai fait une projection dans les onglets en vert qui représente le système de demain.

Puisque le mécanisme est compliqué à expliquer sans avoir les éléments sous les yeux et pour vous aider à mieux comprendre, j'ai mis des commentaires dans chaque onglet expliquant le fonctionnement de l'existant, et le fonctionnement attendu pour demain.

Vous l'avez compris, je fais appel à vous afin d'adapter le système de gestion existant, vers ce qui sera le système de gestion demain, comme expliqué dans les onglets en vert.

Pouvez-vous y jeter un œil, et voir ce qu'il est possible de faire svp ?
J'utilise EXCEL 2007.

Un grand MERCI pour votre aide.
Dom

jpb388 · 30 Juillet 2019

re
je viens de voir un petit bug au niveau de la couleur
dans la macro

VB:

Sub MiseEnPlace(Sh As Worksheet, Rech$, Table$, F1$, F2$, F3$)

après la ligne

Code:

 Set Lr = Range(Table).ListObject.ListRows.Add

tu insères celle ci

Code:

 Lr.Range.Interior.Color = 16777215

ce qui te donnes au final

Code:

                Set Lr = Range(Table).ListObject.ListRows.Add
                Lr.Range.Interior.Color = 16777215
                Lr.Range(1) = Sh.Range("C" & Cel.Row).Text

j'ai essayé en équipe 1 t1 en équpe 1 t2 et en équipe 2 t1 pas de soucis couleur comprise

Domi_49 · 30 Juillet 2019

jpb388 à dit:
re
je viens de voir un petit bug au niveau de la couleur
dans la macro

VB:

Sub MiseEnPlace(Sh As Worksheet, Rech$, Table$, F1$, F2$, F3$)

après la ligne

Code:

Set Lr = Range(Table).ListObject.ListRows.Add

tu insères celle ci

Code:

Lr.Range.Interior.Color = 16777215

ce qui te donnes au final

Code:

Set Lr = Range(Table).ListObject.ListRows.Add Lr.Range.Interior.Color = 16777215 Lr.Range(1) = Sh.Range("C" & Cel.Row).Text

j'ai essayé en équipe 1 t1 en équpe 1 t2 et en équipe 2 t1 pas de soucis couleur comprise

Merci Jpb, j'avais remarqué en effet.
Je viens de faire la modif avec tes indications, nickel.

Pour le copier-coller des commentaires, je regarde demain à nouveau.
C'est étrange car je suis parti du dernier fichier le 01/07 à 13h57, et ça ne semble pas fonctionner.

Peux-tu m'envoyer le fichier avec lequel ton test est concluant stp ?

Merci.
Dom

jpb388 · 30 Juillet 2019

le voici
Bonne journée

Domi_49 · 31 Juillet 2019

jpb388 à dit:
le voici
Bonne journée

Bonjour JPB,

Okkkkkk, je viens de comprendre qu'on ne sait pas bien compris en fait .
Je me suis peut-être mal exprimé.
Lorsque je parle de "commentaire", je parle du commentaire en faisant un clic droit sur la cellule voulue > Insérer un commentaire.

Je te mets le fichier, regarde dans l'onglet EQ_1, cellule BP17, il y a un commentaire. L'idée est de le transposer également dans l'onglet S31.

Merci
Dom

jpb388 · 31 Juillet 2019

Bonjour à tous

dans mProc tu remplaces la macro par celle ci

VB:

Sub MiseEnPlace(Sh As Worksheet, Rech$, Table$, F1$, F2$, F3$)
    Dim I%, Deb%, Fin%, Lg&, Plage As Range, Cel As Range
    Dim Lr As ListRow, Trv As Boolean
    Lg = Sh.Range("C" & Rows.Count).End(xlUp).Row
    If Lg = 16 Then Exit Sub
    For I = 4 To 316 Step 6
       If Sh.Cells(14, I) = "S" & ActiveSheet.Name Then Deb = I: Fin = I + 5: Exit For
    Next I
    If Deb = 0 Or Fin = 0 Then Exit Sub
    Application.ScreenUpdating = False
    Set Plage = Sh.Range(Sh.Cells(17, Deb), Sh.Cells(Lg, Fin))
    For Each Cel In Plage
        If Cel.Column = Deb Then
            If Verif(Sh.Range(Sh.Cells(Cel.Row, Deb), Sh.Cells(Cel.Row, Fin)), Rech) = True Then
                Set Lr = Range(Table).ListObject.ListRows.Add
                Lr.Range.Interior.Color = 16777215
                Lr.Range.ClearComments
                Lr.Range(1) = Sh.Range("C" & Cel.Row).Text
                Lr.Range(1).Interior.Color = Couleur(Sh.Range("C" & Cel.Row))
                Trv = True
            End If
        End If
        Select Case Cel.Text
             Case F1, F2, F3
             Case Else
                If Trv = True Then
                    With Lr.Range(Cel.Column - Deb + 2)
                        .Value = Cel.Text
                        .Interior.Color = Couleur(Sh.Range(Cel.Address), 1)
                        If Not Cel.Comment Is Nothing Then
                            .AddComment
                            .Comment.Text Cel.Comment.Text
                        End If
                    End With
                End If
       End Select
       If Cel.Column = Fin Then Trv = False
    Next Cel
    Application.ScreenUpdating = True
End Sub

et dans mEfface

Code:

Sub SousEfface(Table$)
    With Range(Table)
        If Not .ListObject.DataBodyRange Is Nothing Then
            .ClearComments
            .Interior.Pattern = xlNone
            .ListObject.DataBodyRange.Delete
        End If
    End With
End Sub

Bonne journée

Domi_49 · 31 Juillet 2019

jpb388 à dit:

Bonjour à tous

dans mProc tu remplaces la macro par celle ci

VB:

Sub MiseEnPlace(Sh As Worksheet, Rech$, Table$, F1$, F2$, F3$)
    Dim I%, Deb%, Fin%, Lg&, Plage As Range, Cel As Range
    Dim Lr As ListRow, Trv As Boolean
    Lg = Sh.Range("C" & Rows.Count).End(xlUp).Row
    If Lg = 16 Then Exit Sub
    For I = 4 To 316 Step 6
       If Sh.Cells(14, I) = "S" & ActiveSheet.Name Then Deb = I: Fin = I + 5: Exit For
    Next I
    If Deb = 0 Or Fin = 0 Then Exit Sub
    Application.ScreenUpdating = False
    Set Plage = Sh.Range(Sh.Cells(17, Deb), Sh.Cells(Lg, Fin))
    For Each Cel In Plage
        If Cel.Column = Deb Then
            If Verif(Sh.Range(Sh.Cells(Cel.Row, Deb), Sh.Cells(Cel.Row, Fin)), Rech) = True Then
                Set Lr = Range(Table).ListObject.ListRows.Add
                Lr.Range.Interior.Color = 16777215
                Lr.Range.ClearComments
                Lr.Range(1) = Sh.Range("C" & Cel.Row).Text
                Lr.Range(1).Interior.Color = Couleur(Sh.Range("C" & Cel.Row))
                Trv = True
            End If
        End If
        Select Case Cel.Text
             Case F1, F2, F3
             Case Else
                If Trv = True Then
                    With Lr.Range(Cel.Column - Deb + 2)
                        .Value = Cel.Text
                        .Interior.Color = Couleur(Sh.Range(Cel.Address), 1)
                        If Not Cel.Comment Is Nothing Then
                            .AddComment
                            .Comment.Text Cel.Comment.Text
                        End If
                    End With
                End If
       End Select
       If Cel.Column = Fin Then Trv = False
    Next Cel
    Application.ScreenUpdating = True
End Sub

et dans mEfface

Code:

Sub SousEfface(Table$)
    With Range(Table)
        If Not .ListObject.DataBodyRange Is Nothing Then
            .ClearComments
            .Interior.Pattern = xlNone
            .ListObject.DataBodyRange.Delete
        End If
    End With
End Sub

Bonne journée

PERFECTO !!

Merci encore
Dom

Domi_49 · 4 Janvier 2021

jpb388 à dit:

Bonjour à tous

dans mProc tu remplaces la macro par celle ci

VB:

Sub MiseEnPlace(Sh As Worksheet, Rech$, Table$, F1$, F2$, F3$)
    Dim I%, Deb%, Fin%, Lg&, Plage As Range, Cel As Range
    Dim Lr As ListRow, Trv As Boolean
    Lg = Sh.Range("C" & Rows.Count).End(xlUp).Row
    If Lg = 16 Then Exit Sub
    For I = 4 To 316 Step 6
       If Sh.Cells(14, I) = "S" & ActiveSheet.Name Then Deb = I: Fin = I + 5: Exit For
    Next I
    If Deb = 0 Or Fin = 0 Then Exit Sub
    Application.ScreenUpdating = False
    Set Plage = Sh.Range(Sh.Cells(17, Deb), Sh.Cells(Lg, Fin))
    For Each Cel In Plage
        If Cel.Column = Deb Then
            If Verif(Sh.Range(Sh.Cells(Cel.Row, Deb), Sh.Cells(Cel.Row, Fin)), Rech) = True Then
                Set Lr = Range(Table).ListObject.ListRows.Add
                Lr.Range.Interior.Color = 16777215
                Lr.Range.ClearComments
                Lr.Range(1) = Sh.Range("C" & Cel.Row).Text
                Lr.Range(1).Interior.Color = Couleur(Sh.Range("C" & Cel.Row))
                Trv = True
            End If
        End If
        Select Case Cel.Text
             Case F1, F2, F3
             Case Else
                If Trv = True Then
                    With Lr.Range(Cel.Column - Deb + 2)
                        .Value = Cel.Text
                        .Interior.Color = Couleur(Sh.Range(Cel.Address), 1)
                        If Not Cel.Comment Is Nothing Then
                            .AddComment
                            .Comment.Text Cel.Comment.Text
                        End If
                    End With
                End If
       End Select
       If Cel.Column = Fin Then Trv = False
    Next Cel
    Application.ScreenUpdating = True
End Sub

et dans mEfface

Code:

Sub SousEfface(Table$)
    With Range(Table)
        If Not .ListObject.DataBodyRange Is Nothing Then
            .ClearComments
            .Interior.Pattern = xlNone
            .ListObject.DataBodyRange.Delete
        End If
    End With
End Sub

Bonne journée

Bonjour JPB388,

Je te présente mes meilleurs voeux pour cette nouvelle année, où le souhait d'une bonne santé a encore plus de sens actuellement.

Je me permets de remonter ce vieux sujet, car je rencontre une problématique : Nous entamons une nouvelle année, et le fichier s'ouvre en principe sur l'onglet de la semaine 1.
Pour mémoire, tu as fait en sorte que le fichier s'ouvre sur l'onglet de la semaine en cours.

A l'ouverture du fichier, j'ai le message d'erreu
"Erreur d'execution '9':
L'indice n'appartient pas à la séléction".

Et lorsque je clique sur le bouton "Débogage", la ligne jaune en erreur est la 4ème :

VB:

Sub MonRuban_OnLoad(ribbon As IRibbonUI)
    Dim Num$
    Set Ruban = ribbon
    Ruban.ActivateTab "tab1"
    Worksheets(Format(Date, "ww", vbMonday, vbFirstFourDays)).Activate

Est-il possible que cela provienne du numéro de l'onglet S01, où le 0 ne serait pas pris en compte (valeur nulle) ?

De ce fait, le processus de copier-coller ne fonctionne plus.
J'imagine que tu as traité beaucoup de sujet depuis notre dernier échange, je te laisse te replonger dans ce sujet.

Si tu as besoin d'éléments supplémentaires, n'hésite pas.

Un grand merci de ton aide et de ta dispo
Dom

jpb388 · 5 Janvier 2021

Bonjour à tous
je te remercie pour tes vœux et te présente les miens

c'est exactement ça le 0 remplace la macro par celle ci

VB:

Sub MonRuban_OnLoad(ribbon As IRibbonUI)
    Dim Num$, Sem$
    Set Ruban = ribbon
    Ruban.ActivateTab "tab1"
    Sem = Format(Date, "ww", vbMonday, vbFirstFourDays)
    Select Case Sem
      Case 1 To 9: Sem = "0" & Sem
      Case Else
    End Select
    Worksheets(Sem).Activate
End Sub

une fois changé il est impératif de redémarrer Excel
merci de me mettre un petit mot si ok ou pas

Domi_49 · 5 Janvier 2021

jpb388 à dit:
Bonjour à tous
je te remercie pour tes vœux et te présente les miens

c'est exactement ça le 0 remplace la macro par celle ci

VB:

Sub MonRuban_OnLoad(ribbon As IRibbonUI) Dim Num$, Sem$ Set Ruban = ribbon Ruban.ActivateTab "tab1" Sem = Format(Date, "ww", vbMonday, vbFirstFourDays) Select Case Sem Case 1 To 9: Sem = "0" & Sem Case Else End Select Worksheets(Sem).Activate End Sub

une fois changé il est impératif de redémarrer Excel
merci de me mettre un petit mot si ok ou pas

Bonjour JPB388,

Je viens de remplacer la macro comme tu l'as suggéré, et à l'ouverture du fichier, plus de message d'erreur.
Ca, c'est top.

Je rencontre quand même un souci lors de l'intégration des équipes.
Explication : je me mets sur l'onglet de la S02, et je cliques sur le bouton le + à gauche du ruban pour lancer l'intégration, et message
"Erreur d'éxecution '1004':
La méthode 'Range' de l'objet '_Global' a échoué.

La macro est celle-ci

VB:

Sub MiseEnPlace(Sh As Worksheet, Rech$, Table$, F1$, F2$, F3$)
    Dim I%, Deb%, Fin%, Lg&, Plage As Range, Cel As Range
    Dim Lr As ListRow, Trv As Boolean
    Lg = Sh.Range("C" & Rows.Count).End(xlUp).Row
    If Lg = 16 Then Exit Sub
    For I = 4 To 316 Step 6
       If Sh.Cells(14, I) = "S" & ActiveSheet.Name Then Deb = I: Fin = I + 5: Exit For
    Next I
    If Deb = 0 Or Fin = 0 Then Exit Sub
    Application.ScreenUpdating = False
    Set Plage = Sh.Range(Sh.Cells(17, Deb), Sh.Cells(Lg, Fin))
    For Each Cel In Plage
        If Cel.Column = Deb Then
            If Verif(Sh.Range(Sh.Cells(Cel.Row, Deb), Sh.Cells(Cel.Row, Fin)), Rech) = True Then
                Set Lr = Range(Table).ListObject.ListRows.Add
                Lr.Range.Interior.Color = 16777215
                Lr.Range.ClearComments
                Lr.Range(1) = Sh.Range("C" & Cel.Row).Text
                Lr.Range(1).Interior.Color = Couleur(Sh.Range("C" & Cel.Row))
                Trv = True
            End If
        End If
        Select Case Cel.Text
             Case F1, F2, F3
             Case Else
                If Trv = True Then
                    With Lr.Range(Cel.Column - Deb + 2)
                        .Value = Cel.Text
                        .Interior.Color = Couleur(Sh.Range(Cel.Address), 1)
                        If Not Cel.Comment Is Nothing Then
                            .AddComment
                            .Comment.Text Cel.Comment.Text
                        End If
                    End With
                End If
       End Select
       If Cel.Column = Fin Then Trv = False
    Next Cel
    Application.ScreenUpdating = True
End Sub

et la ligne jaune en erreur est

Code:

Set Lr = Range(Table).ListObject.ListRows.Add

J'ai le même message d'erreur si j'utilise les boutons EFFACER :

Code:

Sub SousEfface(Table$)
    With Range(Table)
        If Not .ListObject.DataBodyRange Is Nothing Then
            .ClearComments
            .Interior.Pattern = xlNone
            .ListObject.DataBodyRange.Delete
        End If
    End With
End Sub

La 2ème ligne est celle qui sort en erreur.

Merci à toi
Dom

jpb388 · 11 Janvier 2021

Bonjour à tous
Tu as fais des copier coller sans renommer les tables

tu colles cette macro dans le module mProc, puis tu clic sur une ligne et tu appuies sur la touche F5 et cela renommera tes tables comme il faut

VB:

Sub RenommeTable()
      Dim sh As Worksheet, I As Byte, Mot$
      For Each sh In Sheets
            Select Case sh.Name
                  Case "Equipe 1", "Equipe 2", "Feuil1"
                  Case Else
                        For I = 1 To 6
                              Select Case I
                                    Case 1: Mot = "E1T1"
                                    Case 2: Mot = "E2T1"
                                    Case 3: Mot = "N1"
                                    Case 4: Mot = "E1T2"
                                    Case 5: Mot = "E2T2"
                                    Case 6: Mot = "N2"
                              End Select
                              Worksheets(sh.Name).ListObjects(I).Name = "S" & sh.Name & Mot
                        Next
                       
            End Select
      Next sh
     
End Sub

Domi_49 · 12 Janvier 2021

jpb388 à dit:

Bonjour à tous
Tu as fais des copier coller sans renommer les tables

tu colles cette macro dans le module mProc, puis tu clic sur une ligne et tu appuies sur la touche F5 et cela renommera tes tables comme il faut

VB:

Sub RenommeTable()
      Dim sh As Worksheet, I As Byte, Mot$
      For Each sh In Sheets
            Select Case sh.Name
                  Case "Equipe 1", "Equipe 2", "Feuil1"
                  Case Else
                        For I = 1 To 6
                              Select Case I
                                    Case 1: Mot = "E1T1"
                                    Case 2: Mot = "E2T1"
                                    Case 3: Mot = "N1"
                                    Case 4: Mot = "E1T2"
                                    Case 5: Mot = "E2T2"
                                    Case 6: Mot = "N2"
                              End Select
                              Worksheets(sh.Name).ListObjects(I).Name = "S" & sh.Name & Mot
                        Next
                      
            End Select
      Next sh
    
End Sub

Bonjour JPB388,

Top,merci.!
Petit récap :
En utilisant cette méthode dans le fichier que je t'ai joins hier, ça fonctionne.
Or, suis mon fichier original, ça coince. Est-ce à cause des onglets supplémentaires que j'ai de mon original ?

A part ça, je ne vois pas de différence.

Merci.
Dom

jpb388 · 12 Janvier 2021

Bonjour

Case "Equipe 1", "Equipe 2", "Feuil1"

sur cette ligne tu rajoutes les feuilles qui ne sont pas des semaines
n'oublie pas les , et les ""
a+

Domi_49 · 13 Janvier 2021

jpb388 à dit:
Bonjour

sur cette ligne tu rajoutes les feuilles qui ne sont pas des semaines
n'oublie pas les , et les ""
a+

Bonsoir JPB388,

Yes, tout est nickel .
Merci beaucoup pour ton aide une nouvelle fois.

Je te souhaite une bonne continuation, attention à toi ;-)
Dom

Autres Tableau de gestion d'effectif

Domi_49

XLDnaute Nouveau

Pièces jointes

jpb388

XLDnaute Accro

Domi_49

XLDnaute Nouveau

jpb388

XLDnaute Accro

Pièces jointes

Domi_49

XLDnaute Nouveau

Pièces jointes

jpb388

XLDnaute Accro

Domi_49

XLDnaute Nouveau

Domi_49

XLDnaute Nouveau

jpb388

XLDnaute Accro

Domi_49

XLDnaute Nouveau

jpb388

XLDnaute Accro

Domi_49

XLDnaute Nouveau

jpb388

XLDnaute Accro

Domi_49

XLDnaute Nouveau

Discussions similaires