Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2016 Copie transposée de planning

halecs93

XLDnaute Impliqué
Bonjour,

Encore une fois, un grand merci aux contributeurs du forum pour l'aide apportée.

J'ai réussi à mettre en place mon outil de gestion automatique de planning de personnels.

J'ai voulu le compléter de façon à copier chaque planning créé sur une feuille unique, et de façon transposée, afin de visualiser l'ensemble d'une semaine pour l'ensemble des personnes.

Ne réussissant pas, j'ai fait un test grâce à l'enregistreur de macro. la macro se nomme 'generation'. Cela donne une idée du résultat souhaité.

Y aurait-il moyen de faire ceci avec un "vrai" code vba : afficher sur la même feuille (dans mon exemple 'feuil2' autant de plannings que ceux générés individuellement. J'ai simplifié mon classeur avec seulement 2 personnes, mais évidemment, il peut y en avoir un nombre aléatoire.

En espérant avoir été clair (heu...)

Encore un grand merci.
 

Pièces jointes

  • PLANNING - TEST - exceldownloads.xlsm
    104.5 KB · Affichages: 13
Solution
Bonjour halecs93, le forum,

Effectivement la macro ActivateWorksheet s'exécutait chez moi en 35 secondes.

J'ai donc mis Application.Calculation = xlCalculationManual en début de macro

et Application.Calculation = xlCalculationAutomatic à la fin.

La durée d'exécution passe à 1,2 seconde.

A+
Trier par date Trier par votes

job75

XLDnaute Barbatruc
Bonjour halecs93, le forum,

Effectivement la macro ActivateWorksheet s'exécutait chez moi en 35 secondes.

J'ai donc mis Application.Calculation = xlCalculationManual en début de macro

et Application.Calculation = xlCalculationAutomatic à la fin.

La durée d'exécution passe à 1,2 seconde.

A+
 

Pièces jointes

  • PLANNING - TEST.xlsm
    875.5 KB · Affichages: 4
Vote positif 0 Vote négatif
Solution

halecs93

XLDnaute Impliqué
Tout simplement...extra. Un grand merci.
 
Vote positif 0 Vote négatif

job75

XLDnaute Barbatruc
Voici une solution très différente qui utilise UserForm3 pout le filtrage avec ce code :
VB: 
Private Sub CommandButton1_Click()
Dim d1 As Object, d2 As Object, i&, x$, transfert As Boolean, lig&, j%
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
For i = 0 To ListBox1.ListCount - 1
    d1(ListBox1.List(i)) = ListBox1.Selected(i)
Next i
For i = 0 To ListBox2.ListCount - 1
    d2(ListBox2.List(i)) = ListBox2.Selected(i)
Next i
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Rows.Hidden = False 'affiche tout
For i = 2 To Cells.SpecialCells(xlCellTypeLastCell).Row
    x = Cells(i, 1)
    If x <> "" Then
        Cells(i + 1, 1).Resize(13) = "" 'RAZ
        If d1(x) Then
            transfert = False
            lig = i
            For j = 0 To 12 Step 2
                If d2(Cells(i + j, 2).Value) Then
                    'transfère le nom en colonne A sur la 1èree ligne visible
                    If Not transfert Then Cells(i + j, 1) = x: transfert = True: lig = i + j
                Else
                    Rows(i + j).Resize(2).Hidden = True
                End If
            Next j
            i = lig
        Else
            Rows(i).Resize(15).Hidden = True
        End If
    End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Unload Me
End Sub

Private Sub UserForm_Initialize()
Dim d As Object, c As Range
Set d = CreateObject("Scripting.Dictionary")
Sheets("RECAP_SEMAINE").Activate
ListBox1.MultiSelect = fmMultiSelectExtended
For Each c In Columns(1).SpecialCells(xlCellTypeConstants)
    If Not d.exists(c.Value) Then
        d(c.Value) = ""
        ListBox1.AddItem c
        ListBox1.Selected(ListBox1.ListCount - 1) = True
    End If
Next c
ListBox2.MultiSelect = fmMultiSelectMulti
For Each c In [B2:B14].SpecialCells(xlCellTypeConstants)
    ListBox2.AddItem c
    ListBox2.Selected(ListBox2.ListCount - 1) = True
Next c
End Sub
UserForm3 s'ouvre en cliquant sur le bouton situé en A1.

Edit : dans le fichier j'ai supprimé la variable lig puisqu'il y a un pas de 15.
 

Pièces jointes

  • PLANNING - TEST FILTRE(1).xlsm
    873.5 KB · Affichages: 1
Dernière édition:
Vote positif 0 Vote négatif

halecs93

XLDnaute Impliqué
C'est très intéressant ce filtrage par userform.... mais, si je ne me trompe pas, on ne peut pas choisir plusieurs items contrairement au filtre habituel
 
Vote positif 0 Vote négatif

halecs93

XLDnaute Impliqué
halecs93 à dit:
C'est très intéressant ce filtrage par userform.... mais, si je ne me trompe pas, on ne peut pas choisir plusieurs items contrairement au filtre habituel
Cliquez pour agrandir...
Pour le coup, j'ai un peu modifié votre code de façon à permettre une multi-sélection et de désélectionner l'ensemble des items des listbox :

VB: 
Option Explicit

Private Sub CommandButton1_Click()
    Dim d1 As Object, d2 As Object, i&, x$, transfert As Boolean, lig&, j%
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    For i = 0 To ListBox1.ListCount - 1
        d1(ListBox1.List(i)) = ListBox1.Selected(i)
    Next i
    For i = 0 To ListBox2.ListCount - 1
        d2(ListBox2.List(i)) = ListBox2.Selected(i)
    Next i
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Rows.Hidden = False 'affiche tout
    For i = 2 To Cells.SpecialCells(xlCellTypeLastCell).Row
        x = Cells(i, 1)
        If x <> "" Then
            Cells(i + 1, 1).Resize(13) = "" 'RAZ
            If d1(x) Then
                transfert = False
                lig = i
                For j = 0 To 12 Step 2
                    If d2(Cells(i + j, 2).Value) Then
                        'transfère le nom en colonne A sur la 1èree ligne visible
                        If Not transfert Then Cells(i + j, 1) = x: transfert = True: lig = i + j
                    Else
                        Rows(i + j).Resize(2).Hidden = True
                    End If
                Next j
                i = lig
            Else
                Rows(i).Resize(15).Hidden = True
            End If
        End If
    Next i
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Unload Me
End Sub


Private Sub UserForm_Initialize()
    Dim d As Object, c As Range
    Set d = CreateObject("Scripting.Dictionary")
    Sheets("RECAP_SEMAINE").Activate
    ListBox1.MultiSelect = fmMultiSelectMulti
    For Each c In Columns(1).SpecialCells(xlCellTypeConstants)
        If Not d.exists(c.Value) Then
            d(c.Value) = ""
            ListBox1.AddItem c
            ListBox1.Selected(ListBox1.ListCount - 1) = True
        End If
    Next c
    ListBox2.MultiSelect = fmMultiSelectMulti
    For Each c In [B2:B14].SpecialCells(xlCellTypeConstants)
        ListBox2.AddItem c
        ListBox2.Selected(ListBox2.ListCount - 1) = True
    Next c
End Sub

Private Sub CommandButton3_Click()
    Dim i As Integer
    ' Désélectionne tous les éléments de la ListBox1
    For i = 0 To ListBox1.ListCount - 1
        ListBox1.Selected(i) = False
    Next i
End Sub

Private Sub CommandButton4_Click()
    Dim i As Integer
    ' Désélectionne tous les éléments de la ListBox2
    For i = 0 To ListBox2.ListCount - 1
        ListBox2.Selected(i) = False
    Next i
End Sub
 

Pièces jointes

  • PLANNING - MODELE 2024 - bis.xlsm
    860.7 KB · Affichages: 3
Vote positif 0 Vote négatif

job75

XLDnaute Barbatruc
halecs93 à dit:
C'est très intéressant ce filtrage par userform.... mais, si je ne me trompe pas, on ne peut pas choisir plusieurs items contrairement au filtre habituel
Cliquez pour agrandir...
Vous vous trompez complètement on peut choisir bien sûr plusieurs items.

Puisque ListBox1 a la propriété MultiSelect égale à fmMultiSelectExtended et ListBox2 égale à fmMultiSelectMulti, vous n'avez pas bien testé mon fichier.

Pour ListBox1 maintenez la touche Ctrl (ou Maj) enfoncée.
 
Vote positif 0 Vote négatif

halecs93

XLDnaute Impliqué
Tout à fait...mais je voulais éviter l'utilisation de la touche Ctrl

Quoi qu'il en soit.... toutes vos propositions m'ont plus qu'aidé
 
Vote positif 0 Vote négatif

job75

XLDnaute Barbatruc
Bien comprendre qu'à l'ouverture tous les éléments sont sélectionnés.

Si l'on met ListBox1 sur fmMultiSelectMulti il faut cliquer sur chaque élément pour désélectionner.
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

  • Résolu(e)
XL 2016 Génération automatique de planning
2
Réponses
15
Affichages
971
ChTi160
A
  • Question
Microsoft 365 Fichier de statistique et roulement
Réponses
0
Affichages
433
Aurel’Byylieve
A
A
  • Question
XL 2021 Panning de 8 conseillers en insertion pour visites a domicile sur 4 secteurs en binome
Réponses
11
Affichages
361
klin89
  • Résolu(e)
XL 2016 éviter le chevauchement de créneaux horaires
Réponses
2
Affichages
291
halecs93
W
  • Question
XL 2016 Joindre par mail un fichier.pdf personnalité selon le prénom trouvé dans le titre du pdf
Réponses
8
Affichages
602
TooFatBoy
  • Résolu(e)
XL 2016 planning horaire hebdomadaire
Réponses
7
Affichages
951
Hubert1959
H
  • Résolu(e)
XL 2016 filtrer des lignes en vba
2 3 4
Réponses
53
Affichages
2 K
job75
T
  • Résolu(e)
XL 2016 comment mettre sur pieds un tableau de bord à partir des données d'un planning annuel
Réponses
9
Affichages
662
therse
T
I
  • Question
XL 2019 (RESOLU) Date de dernière modification d'une plage de cellule
Réponses
3
Affichages
927
patricktoulon
S
  • Résolu(e)
Microsoft 365 Planning astreinte Excel
2
Réponses
25
Affichages
8 K
Deadpool_CC
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…