Un peu perdu sur une macro

Question

Ca fait quelques temps que je parcours le forum (très riche) et à mon tour de poser ce qui est un souci pour moi, je vais essayer de formuler clairement (en plus en termes de macro je suis niveau -2) sur la base de ce tableau en appuyant sur un bouton (cachant une macro donc..) j'aimerais pouvoir sortir dans un nouvel onglet un tableau qui ne donnerait que les cellules non vides de avril / mai / juin / juillet pour une personne donnée par exemple pour marc cela donnerait ce tableau on ne prend donc en compte que les lignes 5 et 8 car la 6 est vide sur les mois concernés la cerise sur le gâteau serait d'avoir aussi un menu déroulant avec item rouge / orange / vert j'avoue je ne sais pas trop par quel bout prendre l'histoire (sachant bien sur que le tableau initial est bien plus complexe que les copies d'écran mais bon..) Si vous savez faire je suis preneur d'explications, j'espère que l'exposé aura été clair...

Geof52 · Answer

Tu devrais joindre le fichier avec ce bouton et peut-etre expliquer ce que tu entend par Item et a quoi correspondrait le rouge, le orange et le vert A+...

Geof52 · Answer

Je n'ai toujours pas compris la partie "Items" et les couleurs

Mais pour le reste, un truc comme ça (bouton en cellule A1) :

15testmjarvis-geof.xlsm (27.51 Ko)

(en plus en termes de macro je suis niveau -2)

J'ai essayé de mettre des commentaires pour chaque action que fait la procedure
Des variables avec un nom qui correspond a son utilité.

Si le resultat te plaît et qu'il y a des lignes de codes que tu ne comprend pas, on peux pousser les explications.

Code (dans le module M_Synthese):

Option Explicit
Sub Synthese()

Dim DerLigneNom As Integer, Ligne As Integer
Dim RangeNom As Range, Nom As Range
Dim Dico As Object
Dim Sh As Variant, CreaFeuille As Variant

Set Dico = CreateObject("Scripting.Dictionary")

'On recherche la derniere ligne utilisée et on défini tous les chefs de projet
DerLigneNom = Sheets("Facturation_2024").Range("B" & Rows.Count).End(xlUp).Row
Set RangeNom = Sheets("Facturation_2024").Range("B3:B" & DerLigneNom)

'On stock dans un dictionnaire les noms en valeurs unique
For Each Nom In RangeNom
    If Not Dico.exists(Nom.Value) Then Dico.Add Nom.Value, Nom.Value
Next Nom

'On fait une boucle sur le dico pour creer une feuille copie de la feuille Facturation par Nom
For Each CreaFeuille In Dico.Keys
    'Verifier qu'une feuille n'a pas déja le Nom d'un chef
    For Each Sh In Worksheets
        If Sh.Name = CreaFeuille Then
            If MsgBox("Une feuille est déja au nom de " & CreaFeuille & Chr(10) & "Voulez-vous la remplacer ?", vbYesNo + vbQuestion, "Confirmation") = vbYes Then
                Application.DisplayAlerts = False
                Sheets(CreaFeuille).Delete
                Application.DisplayAlerts = True
            Else
                GoTo Feuille_Suivante
            End If
        End If
    Next Sh

    'Creation dune feuille
    Sheets("Facturation_2024").Copy After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = CreaFeuille
    With Sheets(CreaFeuille)
        .Activate
        .Shapes.Range(Array("Button 1")).Delete
        .Columns(52).Delete
        .Range(Columns(44), Columns(50)).Delete
        .Range(Columns(3), Columns(38)).Delete
'        .Columns(1).Delete
        'Pour ne garder que le Nom qui correspond a la feuille
        For Ligne = DerLigneNom To 3 Step -1
            If .Cells(Ligne, 2).Value <> CreaFeuille Then .Rows(Ligne).Delete
        Next Ligne
    End With

Feuille_Suivante:
Next CreaFeuille
Sheets("Facturation_2024").Activate
End Sub

Klin89 · Answer

J'ai viré toutes tes pseudo-listes déroulantes qui ne faisaient référence à aucune liste. Essaie ceci : Option Explicit Sub test() Dim a, w(), i As Long, j As Long Dim dico As Object, wsName As String Set dico = CreateObject("Scripting.Dictionary") dico.CompareMode = 1 With Sheets("Facturation_2024").Cells(1).CurrentRegion.Resize(, 52) a = Application.Index(.Value, Evaluate("row(1:" & _ .Rows.Count & ")"), Array(2, 39, 40, 41, 42, 51)) End With For i = 2 To UBound(a, 1) If Len(Join(Application.Index(a, i, Array(2, 3, 4, 5)), "")) &gt; 0 Then If Not dico.exists(a(i, 1)) Then ReDim w(1 To UBound(a, 2), 1 To 2) For j = 1 To UBound(a, 2) w(j, 1) = a(1, j) Next j Else w = dico(a(i, 1)) ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1) End If For j = 1 To UBound(a, 2) w(j, UBound(w, 2)) = a(i, j) Next j dico(a(i, 1)) = w End If Next Application.ScreenUpdating = False For i = 0 To dico.Count - 1 wsName = dico.keys()(i) If Not Evaluate("isref('" & wsName & "'!a1)") Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = wsName End If With Sheets(wsName) .Cells.Clear With .Cells(2, 1).Resize(UBound(dico.items()(i), 2), UBound(dico.items()(i), 1)) .Value = Application.Transpose(dico.items()(i)) .Font.Name = "calibri" .Font.Size = 10 .BorderAround Weight:=xlThin .Borders(xlInsideVertical).Weight = xlThin With .Rows(1) .BorderAround Weight:=xlThin .HorizontalAlignment = xlCenter .Interior.ColorIndex = 44 .Font.Size = 11 End With .Columns.AutoFit End With End With Next Application.ScreenUpdating = True Set dico = Nothing End Sub klin89...

Klin89 · Answer

Re MisterJarvis,

On peut présenter le résultat sous 2 formes.

La code pour la 2ème disposition :

Option Explicit
Sub test2()
Dim a, w(), i As Long, j As Long
Dim dico As Object, wsName As String
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    With Sheets("Facturation_2024").Cells(1).CurrentRegion.Resize(, 52)
        a = Application.Index(.Value, Evaluate("row(1:" & _
                                               .Rows.Count & ")"), Array(2, 39, 40, 41, 42, 51))
    End With
    For i = 2 To UBound(a, 1)
        If Len(Join(Application.Index(a, i, Array(2, 3, 4, 5)), "")) > 0 Then
            If Not dico.exists(a(i, 1)) Then
                ReDim w(1 To UBound(a, 2), 1 To 2)
                For j = 1 To UBound(a, 2)
                    w(j, 1) = a(1, j)
                Next j
            Else
                w = dico(a(i, 1))
                ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1)
            End If
            For j = 1 To UBound(a, 2)
                w(j, UBound(w, 2)) = a(i, j)
            Next j
            dico(a(i, 1)) = w
        End If
    Next
    Application.ScreenUpdating = False
    For i = 0 To dico.Count - 1
        wsName = dico.keys()(i)
        If Not Evaluate("isref('" & wsName & "'!a1)") Then
                Sheets.Add(after:=Sheets(Sheets.Count)).Name = wsName
        End If
        With Sheets(wsName)
            .Cells.Clear
            With .Cells(2, 1).Resize(UBound(Application.Transpose(dico.items()(i)), 2), UBound(Application.Transpose(dico.items()(i)), 1))
                .Value = dico.items()(i)
                .Font.Name = "calibri"
                .Font.Size = 10
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                With .Rows(1)
                    .BorderAround Weight:=xlThin
                    .HorizontalAlignment = xlCenter
                    .Interior.ColorIndex = 44
                    .Font.Size = 11
                End With
                .Columns.AutoFit
            End With
        End With
    Next
    Application.ScreenUpdating = True
    Set dico = Nothing
End Sub

klin89