Autres Tableau de gestion d'effectif

D

Domi_49

XLDnaute Nouveau
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
 

Pièces jointes

  • Test_effectif.xlsm
    143 KB · Affichages: 164
Trier par date Trier par votes
jpb388

jpb388

XLDnaute Accro
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
 
Vote positif 0 Vote négatif
D

Domi_49

XLDnaute Nouveau
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
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
D

Domi_49

XLDnaute Nouveau
jpb388 à dit:
le voici
Bonne journée
Cliquez pour agrandir...

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
 

Pièces jointes

  • Domi49 Test_effectif 2.xlsm
    372.6 KB · Affichages: 14
Vote positif 0 Vote négatif
jpb388

jpb388

XLDnaute Accro
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
 
Vote positif 0 Vote négatif
D

Domi_49

XLDnaute Nouveau
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
Cliquez pour agrandir...
PERFECTO !!

Merci encore ;)
Dom
 
Vote positif 0 Vote négatif
D

Domi_49

XLDnaute Nouveau
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
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
jpb388

jpb388

XLDnaute Accro
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
 
Vote positif 0 Vote négatif
D

Domi_49

XLDnaute Nouveau
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
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
jpb388

jpb388

XLDnaute Accro
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
 
Vote positif 0 Vote négatif
D

Domi_49

XLDnaute Nouveau
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
Cliquez pour agrandir...

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
 
Vote positif 0 Vote négatif

Discussions similaires

Y
  • Question
XL 2016 Tournoi 12 équipes 2 poules de 6
Réponses
1
Affichages
273
Volvo64400
Volvo64400
M
  • Question
XL pour MAC outil de gestion du temps de travail
Réponses
1
Affichages
590
gbinforme
G
M
  • Résolu(e)
Microsoft 365 Gestion numéros de pages du classeur dans une cellule
2
Réponses
16
Affichages
492
sousou
sousou
ArnaudSi
  • Question
XL pour MAC Besoin d'aide pour calculer automatiquement un jour de livraison dans Excel
Réponses
10
Affichages
281
ArnaudSi
ArnaudSi
N
  • Résolu(e)
XL 2016 tableau de vente/gestion des stocks boutique : quelles formules ?!
Réponses
12
Affichages
1 K
Gégé-45550
Gégé-45550
S
  • Résolu(e)
Microsoft 365 Gestion flotte automobile, feuille 1 "accueil" gestion des infos, feuille 2 "tableau" pour consultation"
2
Réponses
15
Affichages
1 K
Phil69970
Phil69970
X
  • Résolu(e)
XL 2016 Problème lors de recherche croisée.
Réponses
4
Affichages
244
Xender
X
D
  • Question
Microsoft 365 Cas réel - avec problème complexe sur de la prevision de match en evitant les doublons
Réponses
1
Affichages
260
Dock91
D
S
  • Question
XL 2016 Création d'indicateur en fonction de la date
Réponses
2
Affichages
370
shaelh
S
T
  • Question
XL 2016 Projet de gestion de planning d'équipes
Réponses
2
Affichages
730
Toofastt
T

Membres actuellement en ligne

15 membres et 208 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 024
Messages
2 084 718
Membres
102 638
dernier inscrit
TOTO33000