XL 2016 Copie transposée de planning

halecs93

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: 11
Solution
job75
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

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: 3
Vote positif 0 Vote négatif
Solution
job75

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

halecs93

XLDnaute Impliqué
job75 à dit:
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.
Cliquez pour agrandir...
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

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

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

halecs93

XLDnaute Impliqué
job75 à dit:
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.
Cliquez pour agrandir...
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

Discussions similaires

halecs93
  • Résolu(e)
XL 2016 Génération automatique de planning
2
Réponses
15
Affichages
497
ChTi160
ChTi160
halecs93
  • Résolu(e)
XL 2016 éviter le chevauchement de créneaux horaires
Réponses
2
Affichages
177
halecs93
halecs93
halecs93
  • Résolu(e)
XL 2016 planning horaire hebdomadaire
Réponses
7
Affichages
706
Hubert1959
H
halecs93
  • Résolu(e)
XL 2016 filtrer des lignes en vba
2 3 4
Réponses
53
Affichages
1 K
job75
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
515
therse
T
I
  • Question
XL 2019 (RESOLU) Date de dernière modification d'une plage de cellule
Réponses
3
Affichages
521
patricktoulon
patricktoulon
S
  • Résolu(e)
Microsoft 365 Planning astreinte Excel
2
Réponses
25
Affichages
6 K
Deadpool_CC
Deadpool_CC
crackerwood
  • Question
XL 2016 Générateur de temps scénario
Réponses
4
Affichages
207
crackerwood
crackerwood
T
  • Question
XL 2016 Projet de gestion de planning d'équipes
Réponses
2
Affichages
759
Toofastt
T
halecs93
  • Question
XL 2019 Références perdues après ajout de colonnes
Réponses
11
Affichages
341
halecs93
halecs93

Membres actuellement en ligne

17 membres et 151 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 209
Messages
2 086 259
Membres
103 167
dernier inscrit
miriame