Discussion :

[goninph]

Bonjour,

Comment faire pour rechercher la date d'aujourd'hui contenue dans la ligne 3 afin de repérer la colonne.
Puis sélectionner toutes les colonnes de la colonne B jusqu'à la colonne aujourd'hui - 7 colonnes, soit une semaine de recul et les supprimer de manière à ne conserver que 7 jours entre la colonne A et la colonne aujourd'hui ?

Voir le fichier joint

Merci et bonne nuit

Philippe

[Invité]

Bonjour,


Une solution possible avec ce code :

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
59
 
Option Explicit
 
Sub DupliquerLePlanning()
 
Dim TitrePlanning As Long
Dim DerniereColonne As Long
Dim I As Long
 
Dim ShProvisoire As Worksheet
 
Dim ShShape As Shape
 
Dim DateTrouvee As Boolean
 
    ' Suppression de l'onglet "Provisoire"
    For Each ShProvisoire In Sheets
        If ShProvisoire.Name = "Provisoire" Then
           Application.DisplayAlerts = False
           ShProvisoire.Delete
           Application.DisplayAlerts = False
           Exit For
        End If
    Next ShProvisoire
 
    Sheets("Planning").Copy after:=Sheets(Sheets.Count)
 
    Set ShProvisoire = ActiveSheet
 
    With ShProvisoire
         .Name = "Provisoire"
         TitrePlanning = 3
         DerniereColonne = .Cells(TitrePlanning, .Columns.Count).End(xlToLeft).Column
         DateTrouvee = False
 
         For I = 2 To DerniereColonne
             If CDate(.Cells(TitrePlanning, I)) = Date Then
                DateTrouvee = True
                Exit For
             End If
         Next I
 
        If I > 10 And DateTrouvee = True Then
           .Range(.Columns(2), .Columns(I - 8)).Delete Shift:=xlToLeft
           .Cells(1, 2) = .Cells(3, 2)
 
        End If
 
        If .Shapes.Count > 0 Then
            For Each ShShape In .Shapes
                If ShShape.Name = "Rectangle 1" Then ShShape.Delete
            Next ShShape
        End If
 
    End With
 
  Set ShProvisoire = Nothing
 
End Sub

Cordialement.

[goninph]

eeeeeeeeeeeeeeeeeeeeh ben mille merci, la classe

J'ai commenter le code, mais quelques subtilités m'échappent, si c'était possible d'ajouter les commentaires manquants .......

Merci et encore merci Eric KERGRESSE

Philippe

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
59
60
Option Explicit
 
Sub DupliquerLePlanning()
 
Dim TitrePlanning As Long
Dim DerniereColonne As Long
Dim I As Long
 
Dim ShProvisoire As Worksheet
 
Dim ShShape As Shape
 
Dim DateTrouvee As Boolean
 
    ' Suppression de l'onglet "Provisoire"
    For Each ShProvisoire In Sheets
        If ShProvisoire.Name = "Provisoire" Then
           Application.DisplayAlerts = False
           ShProvisoire.Delete
           Application.DisplayAlerts = False
           Exit For
        End If
    Next ShProvisoire
 
    Sheets("Planning").Copy after:=Sheets(Sheets.Count)
 
    Set ShProvisoire = ActiveSheet
 
    With ShProvisoire
         .Name = "Provisoire"
         TitrePlanning = 3 'Ligne 3 dans laquelle la recherche de today va se faire
         DerniereColonne = .Cells(TitrePlanning, .Columns.Count).End(xlToLeft).Column 'Cherche la dernière colonne du fichier
         DateTrouvee = False
 
 ' aquoi sert le code ci-dessous???????????????????????????????????????????????????????
         For I = 2 To DerniereColonne
             If CDate(.Cells(TitrePlanning, I)) = Date Then
                DateTrouvee = True
                Exit For
             End If
         Next I
 
        If I > 10 And DateTrouvee = True Then 'si le nombre de colonne entre A et today est supérieur à 8+2 = 10
           .Range(.Columns(2), .Columns(I - 8)).Delete Shift:=xlToLeft 'Selectionne une plage de la colonne 2 à la colonne today - 8 jours et les supprime
'           .Cells(1, 2) = .Cells(3, 2)
 
        End If
' 'Supprime les boutons si il y en a
'        If .Shapes.Count > 0 Then
'            For Each ShShape In .Shapes
'                If ShShape.Name = "Rectangle 1" Then ShShape.Delete
'            Next ShShape
'        End If
 
    End With
 
  Set ShProvisoire = Nothing 'A quoi sert cette fonction ?????????????????????????????????????
 
  Sheets("Planning").Select
End Sub

[goninph]

Hello,

Durant le déroulement de la macro, comment faire pour que la feuille planning reste immobile

Application.ScreenUpdating = True & False n'a pas l'air de fonctionner correctement ou je les ai placées au mauvais endroit ?

Merci et exellente soirée

Philippe

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
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
Option Explicit
 
Sub Création_fichier_image_dans_un_dossier()
 
Dim TitrePlanning As Long
Dim DerniereColonne As Long
Dim I As Long
 
Dim ShProvisoire As Worksheet
 
Dim ShShape As Shape
 
Dim DateTrouvee As Boolean
 
 Application.ScreenUpdating = False ' Désactive le changement des pages à l'écran lors de l'éxécution de la macro
 
 
' Suppression de l'onglet "Provisoire"
    For Each ShProvisoire In Sheets
        If ShProvisoire.Name = "Provisoire" Then
           Application.DisplayAlerts = False
           ShProvisoire.Delete
           Application.DisplayAlerts = False
           Exit For
        End If
    Next ShProvisoire
 
    Sheets("Planning").Copy after:=Sheets(Sheets.Count)
 
    Set ShProvisoire = ActiveSheet
 
    With ShProvisoire
         .Name = "Provisoire"
 
            Columns("A:C").Delete
 
         TitrePlanning = 3 'Ligne 3 dans laquelle la recherche de today va se faire
         DerniereColonne = .Cells(TitrePlanning, .Columns.Count).End(xlToLeft).Column 'Cherche la dernière colonne du fichier
         DateTrouvee = False
 
 ' aquoi sert le code ci-dessous???????????????????????????????????????????????????????
         For I = 2 To DerniereColonne
             If CDate(.Cells(TitrePlanning, I)) = Date Then
                DateTrouvee = True
                Exit For
             End If
         Next I
 
        If I > 10 And DateTrouvee = True Then 'si le nombre de colonne entre A et today est supérieur à 8+2 = 10
           .Range(.Columns(2), .Columns(I - 8)).Delete Shift:=xlToLeft 'Selectionne une plage de la colonne 2 à la colonne today - 8 jours et les supprime
'           .Cells(1, 2) = .Cells(3, 2)
 
        End If
' 'Supprime les boutons si il y en a
'        If .Shapes.Count > 0 Then
'            For Each ShShape In .Shapes
'                If ShShape.Name = "Rectangle 1" Then ShShape.Delete
'            Next ShShape
'        End If
 
    End With
 
  Set ShProvisoire = Nothing 'A quoi sert cette fonction ?????????????????????????????????????
 
 
'  Application.ScreenUpdating = True ' Résactive le changement des pages à l'écran lors de l'éxécution de la macro
 
 
  'Début : Créer le fichier image ==================================================================================
    Dim Img As String
    Dim Plage As Range
    Dim WshShell As Variant
    Dim sRep As Variant
    Dim NomImage As String
 
    Set WshShell = CreateObject("WScript.Shell")
    sRep = ThisWorkbook.Path & "\"
    Set WshShell = Nothing
 
    NomImage = "Planning Team Gonin"
    Img = NomImage & ".png"
 
' Application.ScreenUpdating = False ' Désactive le changement des pages à l'écran lors de l'éxécution de la macro
 
 
        Set Plage = Sheets("Provisoire").Range("A1:DY18")  'DY est le nombre de colonne maxi pour une image exact de bonne qualité
 
'Création d'un fichier image dans le répertoire du fichier Excel
    Plage.CopyPicture
    With Sheets("Provisoire").ChartObjects.Add(0, 0, Plage.Width, Plage.Height)
        .Activate
        .Chart.Paste
        .Chart.Export sRep & Img ' Pour créer un fichier image
    End With
    ActiveSheet.ChartObjects(ActiveSheet.ChartObjects.Count).Delete 'Efface l'image collée sur la page
 
'Fin : Créer le fichier image ==================================================================================
 
Application.ScreenUpdating = True ' Résactive le changement des pages à l'écran lors de l'éxécution de la macro
 
  Sheets("Planning").Select
End Sub

[jerome.vaussenat]

Salut,

tu places ton

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Application.ScreenUpdating =  False

après les déclarations de variables.

Et le

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Application.ScreenUpdating = True

Avant la fin de ta procédure

[Invité]

Bonsoir,

Le code modifié avec quelques conseils :
Et avec un message à la fin, sinon, vous ne voyez pas ce qui s'est passé.....

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
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
 
Option Explicit
 
Sub Creation_Fichier_Image_Dans_Un_DossierV2()
 
' Conseil : Ne pas mettre de caractères accentués dans vos objets : sub, function, variables
 
' Déclarer toutes vos variables en début de procédure
 
Dim TitrePlanning As Long
Dim DerniereColonne As Long
Dim I As Long
 
Dim ShProvisoire As Worksheet
 
Dim ShShape As Shape
 
Dim DateTrouvee As Boolean
 
Dim Img As String
Dim Plage As Range
Dim WshShell As Variant
Dim sRep As Variant
Dim NomImage As String
 
    Application.ScreenUpdating = False ' Désactive le changement des pages à l'écran lors de l'éxécution de la macro
 
    ' Suppression de l'onglet "Provisoire"
    For Each ShProvisoire In Sheets
        If ShProvisoire.Name = "Provisoire" Then
           Application.DisplayAlerts = False
           ShProvisoire.Delete
           Application.DisplayAlerts = False
           Exit For
        End If
    Next ShProvisoire
 
    Sheets("Planning").Copy after:=Sheets(Sheets.Count)
 
    Set ShProvisoire = ActiveSheet
 
    With ShProvisoire
         .Name = "Provisoire"
 
         .Columns("A:C").Delete
 
         TitrePlanning = 3 'Ligne 3 dans laquelle la recherche de today va se faire
         DerniereColonne = .Cells(TitrePlanning, .Columns.Count).End(xlToLeft).Column 'Cherche la dernière colonne du fichier
         DateTrouvee = False
 
         ' Le code ci-dessous sert à trouver la date dans la ligne 3
         For I = 2 To DerniereColonne
             If CDate(.Cells(TitrePlanning, I)) = Date Then
                DateTrouvee = True
                Exit For
             End If
         Next I
 
        If I > 10 And DateTrouvee = True Then 'si le nombre de colonne entre A et today est supérieur à 8+2 = 10
           .Range(.Columns(2), .Columns(I - 8)).Delete Shift:=xlToLeft 'Selectionne une plage de la colonne 2 à la colonne today - 8 jours et les supprime
           .Cells(1, 2) = .Cells(3, 2) ' Permet de remettre le mois en ligne 1
 
        End If
       'Supprime les boutons si il y en a
       ' If .Shapes.Count > 0 Then
       '    For Each ShShape In .Shapes
       '        If ShShape.Name = "Rectangle 1" Then ShShape.Delete
       '    Next ShShape
       ' End If
 
 
        'Début : Créer le fichier image ==================================================================================
        'Création d'un fichier image dans le répertoire du fichier Excel
        sRep = ThisWorkbook.Path & "\"
        NomImage = "Planning Team Gonin"
        Img = NomImage & ".png"
 
        Set Plage = .Range("A1:DY18")  'DY est le nombre de colonne maxi pour une image exact de bonne qualité
        Plage.CopyPicture
        With .ChartObjects.Add(0, 0, Plage.Width, Plage.Height)
             .Chart.Paste
             .Chart.Export sRep & Img ' Pour créer un fichier image
        End With
        .ChartObjects(.ChartObjects.Count).Delete 'Efface l'image collée sur la page
        Set Plage = Nothing
        'Fin : Créer le fichier image ==================================================================================
 
   End With
 
   Set ShProvisoire = Nothing 'Cette commande sert à libérer l'espace mémoire réservée pour cette variable.
 
   Sheets("Planning").Activate
 
   Application.ScreenUpdating = True ' Résactive le changement des pages à l'écran lors de l'éxécution de la macro
 
   MsgBox "Fin de création de l'image : " & NomImage & Chr(10) & "Dans le répertoire : " & sRep, vbInformation
 
 End Sub

Cordialement.

[goninph]

Hello,

Votre code génère une image blanche, il manque le .activate est tout est ok

Encore merci

Bonne soirée

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
       'Début : Créer le fichier image ==================================================================================
        'Création d'un fichier image dans le répertoire du fichier Excel
        sRep = ThisWorkbook.Path & "\"
        NomImage = "Planning Team Gonin"
        Img = NomImage & ".png"
 
        Set Plage = .Range("A1:DY18")  'DY est le nombre de colonne maxi pour une image exact de bonne qualité
        Plage.CopyPicture
        With .ChartObjects.Add(0, 0, Plage.Width, Plage.Height)
 
.activate
 
 
             .Chart.Paste
             .Chart.Export sRep & Img ' Pour créer un fichier image
        End With
        .ChartObjects(.ChartObjects.Count).Delete 'Efface l'image collée sur la page
        Set Plage = Nothing
        'Fin : Créer le fichier image ==================================================================================