Bonjour,

le code ci-dessous me permet de créer des feuilles, tout en recopiant les formules formats, cases à cocher et le graphique de la feuille R0C0 sur chaque nouvelle feuille, j'ai juste un problème avec la dernière procédure: la recopie des étiquettes du graphique ne pointent pas vers les données de la nouvelle feuille, alors que les données des séries pointent bien vers la nouvelle feuille, j'ai tenté différentes approches mais rien n'y a fait... si l'un d'entre vous à la solution pour résoudre ce problème d'étiquettes, je suis preneur.

Merci

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
Sub CreateSheets()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Liste")
    Dim rng As Range
    Set rng = ws.Range("D1:D300")
    Dim cell As Range
 
    ' Copier le graphique depuis "R0C0" une seule fois s'il existe
    Dim chrtObj As ChartObject
    On Error Resume Next
    Set chrtObj = ThisWorkbook.Sheets("R0C0").ChartObjects(1)
    On Error GoTo 0
    If Not chrtObj Is Nothing Then
        chrtObj.Copy
    End If
 
    For Each cell In rng
        If cell.Value <> "" Then
            Dim newSheet As Worksheet
            Set newSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count))
            newSheet.Name = cell.Value
 
            ' Copier les valeurs, formats et formules depuis "R0C0"
            ThisWorkbook.Sheets("R0C0").Cells.Copy
            newSheet.Cells.PasteSpecial xlPasteAll ' Copie les valeurs, les formats et les formules
 
            ' Copier les objets (y compris les cases à cocher) depuis "R0C0" s'il y en a
            Dim sh As Shape
            On Error Resume Next
            For Each sh In ThisWorkbook.Sheets("R0C0").Shapes
                If sh.TopLeftCell.row <= 23 And sh.BottomRightCell.row >= 1 And sh.TopLeftCell.Column <= 27 And sh.BottomRightCell.Column >= 1 Then
                    sh.Copy
                    newSheet.Paste Destination:=newSheet.Range(sh.TopLeftCell.Address) ' Coller les objets sur la nouvelle feuille
                End If
            Next sh
            On Error GoTo 0
 
            ' Coller le graphique dans la nouvelle feuille en C1 s'il existe
            If Not chrtObj Is Nothing Then
                newSheet.Paste Destination:=newSheet.Range("C1")
            End If
 
            ' Mettre à jour les références de cellules dans les séries de données du graphique pour pointer vers les données de la nouvelle feuille
            Dim ser As Series
            For Each ser In newSheet.ChartObjects(1).Chart.SeriesCollection
                ser.formula = Replace(ser.formula, "R0C0", newSheet.Name)
            Next ser
 
            ' Mettre à jour les références de cellules dans les étiquettes du graphique pour pointer vers les données de la nouvelle feuille
            Dim dl As DataLabel
            For Each dl In newSheet.ChartObjects(1).Chart.SeriesCollection(1).DataLabels
                dl.formula = Replace(dl.formula, "R0C0", newSheet.Name)
            Next dl
        End If
    Next cell
 
    ThisWorkbook.Sheets("Liste").Activate
End Sub