XL 2016 Copie transposée de planning

  • Initiateur de la discussion Initiateur de la discussion halecs93
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

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

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

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

Dernière édition:
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
 
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

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.
 
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é 🙂
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Retour