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,

Placez cette macro dans le code de "Feuil2" :
VB: 
Private Sub Worksheet_Activate()
Dim nfeuille%, n%, source As Range, cc%, dest As Range, i%, j%
nfeuille = 2 'à adapter
Application.ScreenUpdating = False
Rows("2:" & Rows.Count).Clear 'RAZ
For n = 1 To nfeuille
    Set source = Sheets(n).[B4:N61]
    cc = source.Columns.Count
    Set dest = [B2:BG14].Offset(15 * (n - 1))
    dest(1, 0) = Sheets(n).Name
    For i = 1 To source.Rows.Count
        For j = 1 To cc
            If i = 1 Or source(i, j).Interior.ColorIndex <> xlNone Then source(i, j).Copy dest(j, i)
Next j, i, n
'---formats---
Cells.WrapText = False
Cells.Font.Size = 11
Cells.Font.Bold = False
Cells.HorizontalAlignment = xlLeft
End Sub
Elle se déclenche quand on active la feuille.

A+
 

Pièces jointes

  • PLANNING - TEST - exceldownloads.xlsm
    125.2 KB · Affichages: 2
Vote positif 0 Vote négatif

halecs93

XLDnaute Impliqué
Activer....donc, sélectionner. Mais il y aurait possibilité de déclencher par un bouton, par exemple, sans sélectionner la feuille ?
 
Vote positif 0 Vote négatif

job75

XLDnaute Barbatruc
Avec un Collage spécial/Transpose c'est bien plus rapide :
VB: 
Private Sub Worksheet_Activate()
Dim nfeuille%, n%, source As Range, dest As Range
nfeuille = 2 'à adapter
Application.ScreenUpdating = False
Rows("2:" & Rows.Count).Clear 'RAZ
For n = 1 To nfeuille
    Set source = Sheets(n).[B4:N61]
    Set dest = [B2].Offset(15 * (n - 1))
    dest(1, 0) = Sheets(n).Name
    source.Copy
    dest.PasteSpecial xlPasteAll, Transpose:=True 'collage spécial
    Application.CutCopyMode = 0
Next n
Application.Goto [A1], True 'cadrage
'---formats---
Cells.WrapText = False
Cells.Font.Size = 11
Cells.Font.Bold = False
Cells.HorizontalAlignment = xlLeft
End Sub
Activer une feuille c'est la mettre au 1er plan en cliquant sur son onglet.
 

Pièces jointes

  • PLANNING - TEST - exceldownloads(1).xlsm
    125.1 KB · Affichages: 3
Vote positif 0 Vote négatif

halecs93

XLDnaute Impliqué
Oui, je venais de modifier ma réponse ainsi : Activer....donc, sélectionner. Mais il y aurait possibilité de déclencher par un bouton, par exemple, sans sélectionner la feuille ?
 
Vote positif 0 Vote négatif

halecs93

XLDnaute Impliqué
Merci. J'ai testé la macro...qui fonctionne avec les deux onglets dans l'exemple. Mais si j'en rajoute un ou plusieurs, cela ne les prend pas tous en compte;...
 
Vote positif 0 Vote négatif

job75

XLDnaute Barbatruc
halecs93 à dit:
Mais il y aurait possibilité de déclencher par un bouton, par exemple, sans sélectionner la feuille ?
Cliquez pour agrandir...
J'espère que vous allez réfléchir et comprendre qu'ici un bouton est totalement inutile.
halecs93 à dit:
Merci. J'ai testé la macro...qui fonctionne avec les deux onglets dans l'exemple. Mais si j'en rajoute un ou plusieurs, cela ne les prend pas tous en compte;...
Cliquez pour agrandir...
Dites donc j'ai bien écrit :
VB: 
nfeuille = 2 'à adapter
 
Vote positif 0 Vote négatif

halecs93

XLDnaute Impliqué
job75 à dit:
J'espère que vous allez réfléchir et comprendre qu'ici un bouton est totalement inutile.

Dites donc j'ai bien écrit :
VB: 
nfeuille = 2 'à adapter
Cliquez pour agrandir...
Le bouton me sera utile...car je veux déclencher par moi même la macro au moment où je le désire.... et en effet, je venais de modifier le nombre de feuille pour l'adapter à mon classeur. Là, je cherhce à décompter automatiquement ce nombre en omettant certaines des feuilles du classeur (modele, planning par exemple)
 
Vote positif 0 Vote négatif

job75

XLDnaute Barbatruc
Bonjour halecs93, le forum,
halecs93 à dit:
Le bouton me sera utile...car je veux déclencher par moi même la macro au moment où je le désire....
Cliquez pour agrandir...
Vous pouvez activer Feuil2 au moment où vous le désirez !!!

Avec bouton => exécution de la macro puis activation de la feuille.

Sans bouton => activation de la feuille ce qui exécute la macro.

Maintenant si les feuilles à copier sont placées n'importe où on peut les distinguer par le fait qu'il y a "LUNDI" en B4, [Edit] en excluant la feuille "MODELE", voyez ce fichier (2) :
VB: 
Private Sub Worksheet_Activate()
Dim feuille As Worksheet, source As Range, dest As Range, n%
Application.ScreenUpdating = False
Rows("2:" & Rows.Count).Clear 'RAZ
For Each feuille In Worksheets
    If UCase(feuille.Range("B4")) = "LUNDI" And UCase(feuille.Name) <> "MODELE" Then
        Set source = feuille.[B4:N61]
        Set dest = Range("B2").Offset(15 * n)
        dest(1, 0) = feuille.Name
        source.Copy
        dest.PasteSpecial xlPasteAll, Transpose:=True 'collage spécial
        Application.CutCopyMode = 0
        n = n + 1
    End If
Next feuille
Application.Goto [A1], True 'cadrage
'---formats---
Cells.WrapText = False
Cells.Font.Size = 11
Cells.Font.Bold = False
Cells.HorizontalAlignment = xlLeft
End Sub
A+
 

Pièces jointes

  • PLANNING - TEST - exceldownloads(2).xlsm
    134.7 KB · Affichages: 2
Dernière édition:
Vote positif 0 Vote négatif

halecs93

XLDnaute Impliqué
Encore merci....

Je continue à "bricoler" pour adapter tout ceci à mon classeur initial (je le mets en pj).

Je cherche, comme sur l'illustration, à compléter certaines lignes de façon automatique. J'envisage, en effet, par la suite, un filtre sur ces colonnes.


 

Pièces jointes

  • PLANNING - TEST.xlsm
    844.3 KB · Affichages: 2
Vote positif 0 Vote négatif

job75

XLDnaute Barbatruc
A mon avis ce bricolage est inutile mais bon utilisez ce fichier (3) et ces 2 macros dans Feuil2 :
VB: 
Sub Effacer()
Dim i&
Application.ScreenUpdating = False
For i = Cells.SpecialCells(xlCellTypeLastCell).Row To 2 Step -1
    If Cells(i, 1) <> "" Then If Cells(i, 1) = Cells(i - 1, 1) Then Cells(i, 1) = ""
    If Cells(i, 2) <> "" Then If Cells(i, 2) = Cells(i - 1, 2) Then Cells(i, 2) = ""
Next i
End Sub

Sub Completer()
Dim i&
Effacer
For i = Cells.SpecialCells(xlCellTypeLastCell).Row + 1 To 2 Step -1
    If Cells(i, 1) <> "" Then Cells(i, 1).Resize(14) = Cells(i, 1)
    If Cells(i, 2) = "" And Cells(i - 1, 2) <> "" Then Cells(i, 2) = Cells(i - 1, 2)
Next i
End Sub
 

Pièces jointes

  • PLANNING - TEST - exceldownloads(3).xlsm
    140.8 KB · Affichages: 1
Vote positif 0 Vote négatif

halecs93

XLDnaute Impliqué
Je regarde tout ceci.... et je reviens vers vus si vous pouvez. Encore merci
 
Vote positif 0 Vote négatif

job75

XLDnaute Barbatruc
Pour aller plus vite utilisez ce fichier (4) avec le tableau a (matrice) :
VB: 
Sub Effacer()
Dim a, i&
With Range("A1:B" & Cells.SpecialCells(xlCellTypeLastCell).Row)
    a = .Value 'matrice, plus rapide
    For i = UBound(a) To 2 Step -1
        If a(i, 1) <> "" Then If a(i, 1) = a(i - 1, 1) Then a(i, 1) = ""
        If a(i, 2) <> "" Then If a(i, 2) = a(i - 1, 2) Then a(i, 2) = ""
    Next i
    .Value = a
End With
End Sub

Sub Completer()
Dim a, i&, x$, j&
Application.ScreenUpdating = False
Effacer
With Range("A1:B" & Cells.SpecialCells(xlCellTypeLastCell).Row + 1)
    a = .Value 'matrice, plus rapide
    For i = UBound(a) To 2 Step -1
        x = a(i, 1)
        If x <> "" Then: For j = i + 1 To i + 13: a(j, 1) = x: Next j
        If a(i, 2) = "" And a(i - 1, 2) <> "" Then a(i, 2) = a(i - 1, 2)
    Next i
    .Value = a
End With
End Sub
 

Pièces jointes

  • PLANNING - TEST - exceldownloads(4).xlsm
    142.8 KB · Affichages: 4
Vote positif 0 Vote négatif

halecs93

XLDnaute Impliqué
En effet, accélération fulgurante...surtout sur mon fichier initial qui contient bien plus de données. Je poursuis de mon côté
 
Vote positif 0 Vote négatif

halecs93

XLDnaute Impliqué
J'ai adapté (le terme est bien présomptueux) le code de la façon suivante :

Option Explicit

Sub ActivateWorksheet()
Application.ScreenUpdating = False
Rows("2:" & Rows.count).Clear 'RAZ

Dim feuille As Worksheet, source As Range, dest As Range, n%
For Each feuille In Worksheets
If UCase(feuille.Range("B4")) = "LUNDI" And UCase(feuille.Name) <> "MODELE" And UCase(feuille.Name) <> "RECAP_SEMAINE" Then
Set source = feuille.Range("B4:N61")
Set dest = Range("B2").Offset(15 * n)
dest(1, 0) = feuille.Name
source.Copy
dest.PasteSpecial xlPasteAll, Transpose:=True 'collage spécial
Application.CutCopyMode = 0
n = n + 1
End If
Next feuille

Application.Goto [A1], True 'cadrage
'---formats---
Cells.WrapText = False
Cells.Font.Size = 11
Cells.Font.Bold = False
Cells.HorizontalAlignment = xlLeft

Application.ScreenUpdating = True

' Appel des sous-procédures Completer et filtre à la fin de Worksheet_Activate()
Completer
filtre
End Sub

Sub Completer()
Dim a, i&, x$, j&
Application.ScreenUpdating = False
Effacer
With Range("A1:B" & Cells.SpecialCells(xlCellTypeLastCell).Row + 1)
a = .Value 'matrice, plus rapide
For i = UBound(a) To 2 Step -1
x = a(i, 1)
If x <> "" Then
For j = i + 1 To i + 13
a(j, 1) = x
Next j
End If
If a(i, 2) = "" And a(i - 1, 2) <> "" Then
a(i, 2) = a(i - 1, 2)
' Mettre la police de caractères en blanc dans la cellule actuelle de la colonne B
.Cells(i, 2).Font.Color = RGB(255, 255, 255) ' Blanc
' Mettre la police de caractères en blanc dans la cellule correspondante de la colonne A
.Cells(i, 1).Font.Color = RGB(255, 255, 255) ' Blanc
End If
Next i
.Value = a
End With
End Sub

Sub filtre()
Dim lastRow As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet

' Vérifier si un filtre est déjà activé
If Not ws.AutoFilterMode Then
' Trouver la dernière ligne avec des données dans la colonne B
lastRow = ws.Cells(ws.Rows.count, "B").End(xlUp).Row

' Sélectionner la plage de données
ws.Range("A1:B" & lastRow).Select

' Appliquer le filtre
Selection.AutoFilter

' Sélectionner la cellule A1 à la fin de l'exécution
ws.Range("A1").Select
End If
End Sub

Sub Effacer()
Dim a, i&
With Range("A1:B" & Cells.SpecialCells(xlCellTypeLastCell).Row)
a = .Value 'matrice, plus rapide
For i = UBound(a) To 2 Step -1
If a(i, 1) <> "" Then If a(i, 1) = a(i - 1, 1) Then a(i, 1) = ""
If a(i, 2) <> "" Then If a(i, 2) = a(i - 1, 2) Then a(i, 2) = ""
Next i
.Value = a
End With
End Sub


La première partie (Sub ActivateWorksheet()) reste relativement lente dans son exécution. Y aurait-il une autre approche ?
 

Pièces jointes

  • PLANNING - TEST.xlsm
    844.1 KB · Affichages: 4
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
919
ChTi160
A
  • Question
Microsoft 365 Fichier de statistique et roulement
Réponses
0
Affichages
380
Aurel’Byylieve
A
  • Résolu(e)
XL 2016 éviter le chevauchement de créneaux horaires
Réponses
2
Affichages
275
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
573
TooFatBoy
  • Résolu(e)
XL 2016 planning horaire hebdomadaire
Réponses
7
Affichages
912
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
652
therse
T
I
  • Question
XL 2019 (RESOLU) Date de dernière modification d'une plage de cellule
Réponses
3
Affichages
878
patricktoulon
S
  • Résolu(e)
Microsoft 365 Planning astreinte Excel
2
Réponses
25
Affichages
8 K
Deadpool_CC
L
de merci et d'Excel...
Réponses
0
Affichages
258
louis59
L
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…