Discussion :

[macat]

Bonjour,
J'arrive à me débrouiller un peu maintenant grâce à vous tous, mais là un hic.
Ce sont d'anciennes macros que j'adapte au besoin depuis... j'ai beau les relire je ne voix pas ce qui cloche.

- Je n'arrive pas à copier la colonne b dans les NewSht en colonne B, alors qu'avec la A pas de soucis. D'habitude je ne rencontre pas de difficulté à faire des adaptations.

La Macro Public Sub FeuilNomCreate() bloque à NewSht.Name = NewShtName, avec erreur d'exécution '1004' : la méthode 'Name' de l'objet'_Worksheet' a échoué ?!

- Aussi, l'intégration de l'image de la page 4 Entête ne se fait pas avec la macro Public Sub EnteteTotalNom(ByVal NomSht As String) ?!

- Et lorsque qu'il y beaucoup de personne dans le registre le temps de fabrication des newSht est trop trop long ?!

Désolée, si les lignes ne vous semblent plus très bien écrites après mes divers changements, et avec des longueurs inutiles, j'ai essayé pour me repérer de notifier dans la macro qui fait quoi, mais je ne suis pas certaine que se soit bon.

Merci d'avance de ce que vous voudrez bien m'aider pour ce projet presque abouti avec un "sans erreur".

Bien cordialement,

[unparia]

Bonjour
https://www.developpez.net/forums/d8...s-discussions/
Je ne connais donc pas ton code (je n'ouvrirai jamais un classeur tiers) et ne peux donc t'aider.

[Menhir]

La Macro Public Sub FeuilNomCreate() bloque à NewSht.Name = NewShtName, avec erreur d'exécution '1004' : la méthode 'Name' de l'objet'_Worksheet' a échoué ?!

Comme on dit, le diable est dans la variable.
Que contiennent NewSht et NewShtName au moment du plantage ? (aller voir dans la fenêtre de variables locales)

Pour le reste, comme unparia, je n'ouvre pas les pièces jointes.

[Menhir]

Bis...

Que contiennent NewSht et NewShtName au moment du plantage ? (aller voir dans la fenêtre de variables locales)

[macat]

Bonjour,

Oups j'aurai parié que vous aviez de très très bons antivirus désolée
Donc voici le code merci d'avance si on peut me corriger.

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
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
Public Sub RecapForm()
 
Dim I As Integer
Dim Cel As Range
Dim DerLig As Integer
 
DerLig = Sheets("2 Registre").Range("A65536").End(xlUp).Row + 1 'Première ligne vide dans 2 Registre
For I = 2 To Sheets.Count
    If IsNumeric(Left(Sheets(I).Name, 2)) Then
        With Sheets(I)
            For Each Cel In .Range("A2:B" & .Range("A65536").End(xlUp).Row) 'copie col A & B
                If IsDate(Cel.Value) Then
                    'copie Date dans Col A de NewSht
                    Sheets("2 Registre").Range("A" & DerLig) = .Range("A" & Cel.Row)
                    'copie Acte dans Col B de NewSht
                    Sheets("2 Registre").Range("B" & DerLig) = .Range("B" & Cel.Row)
                  DerLig = DerLig + 1 'ligne où copier dans NewSht
                End If
            Next Cel
        End With
    End If
Next I
End Sub
 
Public Sub FeuilNomCreate()
Dim NewSht As Worksheet, sht As Worksheet, ws As Worksheet
Dim LastLig As Long, NewLig As Long
Dim NewShtName As String
Dim Trouve As Boolean
Dim Cel As Range
 
Application.DisplayAlerts = False
Application.ScreenUpdating = False
FeuilNomErase
Set sht = Sheets("2 Registre")
With sht
    LastLig = .Range("A65536").End(xlUp).Row
    If LastLig < 2 Then Exit Sub
 
    For Each Cel In .Range("c2:c" & LastLig) ' Prendre Nom de 2 Registre et mettre dans chaque feuille en C13
        Trouve = False
        NewShtName = Cel.Value
        For Each ws In Worksheets
            If ws.Name = NewShtName Then
                Trouve = True
                Exit For
            End If
        Next ws
 
        If Trouve Then
            Set NewSht = ws
        Else
            Set NewSht = Sheets.Add(After:=Sheets(Sheets.Count))
            NewSht.Name = NewShtName
 
        Selection.Copy
 
        NewSht.Range("A1").Select
 
            NewSht.Range("A15").Value = "Voici votre agenda "
            NewSht.Range("A16").Value = "XXXXXX."
            NewSht.Range("C13").Value = Cel.Value
 
            MiseEnForm (NewShtName)
 
        End If       'Copier de COL A et B de 2 Registre a/c de derlig vide de col B et C mais ne fonctionne pas donc A et B
 
        NewLig = NewSht.Range("B65536").End(xlUp).Row + 1
        .Range("A" & Cel.Row & ":B" & Cel.Row).Copy NewSht.Cells(NewLig, 1)
     Next Cel
     End With
 
For Each ws In Worksheets 'Incertion de l'entête
    If ws.Name <> "2 Registre" And Not IsNumeric(Left(ws.Name, 2)) Then EnteteTotalNom ws.Name
Next ws
 ' Fin du copié de récap
sht.Select
Set sht = Nothing
Set NewSht = Nothing
 
Application.DisplayAlerts = True
Application.ScreenUpdating = True
 
End Sub
 
Public Sub FeuilNomErase()
Dim ws As Worksheet
 
Application.DisplayAlerts = False
Application.ScreenUpdating = False
 
For Each ws In Worksheets
    If ws.Name <> "2 Registre" And Not IsNumeric(Left(ws.Name, 2)) Then ws.Delete
 
Next ws
 
End Sub
 
Public Sub MiseEnForm(ByVal NomSht As String)
Dim LastLig As Long
With Sheets(NomSht)
    LastLig = .Range("A65536").End(xlUp).Row
     Application.PrintCommunication = False
    .Columns("A").ColumnWidth = 15
    .Columns("B").ColumnWidth = 15
    .Columns("C").ColumnWidth = 45
    .Range("A19").Value = "Dates"
    .Range("B19").Value = "Autres"
    .Range("A1:E100").Font.Bold = True
    .Range("A19:E100").HorizontalAlignment = xlCenter
    .Range("A19:E100").VerticalAlignment = xlCenter
    .Range("A19:B19").Interior.ColorIndex = 40 '40=saumon
    .Range("B10").Value = "Ruan, le"
    .Range("B10").HorizontalAlignment = xlRight
    .Range("C13").HorizontalAlignment = xlLeft
    .Range("C10").Value = DateTime.Now()
    .Range("A10").Value = DateTime.Now()
        .Range("C10").NumberFormat = "dd mmmm yyyy."
        .Range("A10").NumberFormat = "hh:mm"
        Range("C10:c10").Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False 'saut à la ligne
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
 
      End With
              Selection.Merge
End With
 
     With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.25)  'marge gauche
        .RightMargin = Application.InchesToPoints(0.25) 'marge droite
        .TopMargin = Application.InchesToPoints(0.31)   'marge haut
        .BottomMargin = Application.InchesToPoints(0.31) 'marge bas
        .HeaderMargin = Application.InchesToPoints(0.19) 'marge tout en haut
        .FooterMargin = Application.InchesToPoints(0.19) 'marge tout en bas
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        HauteurPagePoints = HauteurPagePoints - .TopMargin - .FooterMargin
        LargeurPagePoints = LargeurPagePoints - .LeftMargin - .RightMargin
    End With
    Application.PrintCommunication = True
 
End Sub
 
Sub TriChaqueFeuille()
Dim K As Boolean
Dim I As Integer
Application.ScreenUpdating = False
K = True
Do While K
    K = False
    For I = 1 To ActiveWorkbook.Sheets.Count - 1
        If Sheets(I).Name <> "2 Registre" And Not IsNumeric(Left(Sheets(I).Name, 2)) Then
            If Sheets(I).Name > Sheets(I + 1).Name Then
                Sheets(I).Move After:=Sheets(I + 1)
                K = True
            End If
        Else
            'K = True
        End If
    Next I
Loop
Sheets("2 Registre").Select
Application.ScreenUpdating = False
 
End Sub
 
Public Sub EnteteTotalNom(ByVal NomSht As String)
Dim LastLig As Long
 Application.Goto reference:=Sheets(NomSht).Range("A1"), Scroll:=True
With Sheets(NomSht).PageSetup.LeftHeaderPicture
        'en-tête de page
        .Filename = "C:\Documents and Settings\Bureau\Dates agendas.xls\Direction de la monnaie.bmp"
      End With
ActiveSheet.PageSetup.LeftHeader = "&G" '<-- ajout du code &G
 
End Sub

[unparia]

Oups j'aurai parié que vous aviez de très très bons antivirus

Et moi, je parierais (et gagnerais) que le meilleur des antivirus ne connaitra le prochain virus que lorsque ce virus aura été repéré
Et je parie dans la foulée que ta machine est bourrée de petites "bébêtes", pas forcément dangereuses, mais embarrassantes.
Pas le temps de regarder ton code (partie de pêche en vue). Je le regarderai à mon retour si personne ne te répond entre-temps