XL 2016 Copie transposée de planning

[halecs93]

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.

 

[job75]

Bonjour halecs93,

Placez cette macro dans le code de "Feuil2" :

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+

 

[halecs93]

Bonjour halecs93,

Placez cette macro dans le code de "Feuil2" :

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+

Activer....donc, sélectionner. Mais il y aurait possibilité de déclencher par un bouton, par exemple, sans sélectionner la feuille ?

 

[job75]

Avec un Collage spécial/Transpose c'est bien plus rapide :

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.

 

[halecs93]

Avec un Collage spécial/Transpose c'est bien plus rapide :

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.

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 ?

 

[halecs93]

Avec un Collage spécial/Transpose c'est bien plus rapide :

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.

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

 

[job75]

Mais il y aurait possibilité de déclencher par un bouton, par exemple, sans sélectionner la feuille ?

J'espère que vous allez réfléchir et comprendre qu'ici un bouton est totalement inutile.

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

Dites donc j'ai bien écrit :

nfeuille = 2 'à adapter

 

[halecs93]

J'espère que vous allez réfléchir et comprendre qu'ici un bouton est totalement inutile.

Dites donc j'ai bien écrit :

nfeuille = 2 'à adapter

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)

 

[job75]

Bonjour halecs93, le forum,

Le bouton me sera utile...car je veux déclencher par moi même la macro au moment où je le désire....

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

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+

 

[halecs93]

Bonjour halecs93, le forum,

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

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+

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.

 

[job75]

A mon avis ce bricolage est inutile mais bon utilisez ce fichier (3) et ces 2 macros dans Feuil2 :

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

 

[halecs93]

A mon avis ce bricolage est inutile mais bon utilisez ce fichier (3) et ces 2 macros dans Feuil2 :

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

Je regarde tout ceci.... et je reviens vers vus si vous pouvez. Encore merci

 

[job75]

Pour aller plus vite utilisez ce fichier (4) avec le tableau a (matrice) :

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

 

[halecs93]

Pour aller plus vite utilisez ce fichier (4) avec le tableau a (matrice) :

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

En effet, accélération fulgurante...surtout sur mon fichier initial qui contient bien plus de données. Je poursuis de mon côté

 

[halecs93]

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 ?