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: 12
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+

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

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:

halecs93

XLDnaute Impliqué
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.
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
 

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

job75

XLDnaute Barbatruc
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
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.
 

halecs93

XLDnaute Impliqué
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.
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é :)
 

Discussions similaires

Statistiques des forums

Discussions
313 198
Messages
2 096 141
Membres
106 505
dernier inscrit
ngomez