Discussion :

[antoinepoirier]

Bonjour,

Je suis très nouveau au niveau du VBA Excel. D'ailleurs, je suis nouveau à la programmation en tant que tel. Je désire faire une macro qui prendra la mise en forme de cellules spécifiques de mon document source et ouvrira et copiera automatiquement dans plusieurs autres documents dans le même dossier. Évidemment, j'ai l'idée mais une fois rendu au clavier, c'est autre chose

Je vous demande donc conseil sur la façon dont je devrais m'y prendre... J'ai déjà fait un bout de chemin, c'est-à-dire que mes documents destinataires s'ouvrent, s'enregistrent et se ferment automatiquement. Je suis capable d'écrire dans les documents également... Mais copier/coller du contenu en gardant la mise en forme (je pense à un collage spécial), je n'y arrive pas.

Vous remarquerez, c'est dans la partie 'Change cell value(s) in one worksheet in mybook' que je suis mélangé, le reste ça va je pense bien.
Également, dans les définition de variables, il y a peut-être quelque chose qui cloche...

Veuillez prendre note que ceci est mon premier programme alors allez-y doucement avec la critique s'il-vous-plaît

Voici mon 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
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
 
Option Explicit
Const Pass As String = "0179"
 
Sub Example()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String, Fnum As Long
    Dim mybook As Workbook
    Dim thisbook As Worksheet
    'Dim ActiveWorksheet As Worksheet
    Set thisbook = ActiveWorkbook.Sheets("Paramètres")
    Dim CalcMode As Long
    'Dim sh As Worksheet
    Dim ErrorYes As Boolean
 
    'Fill in the path\folder where the files are
    MyPath = "C:\Documents and Settings\apoirierrouillard\Bureau\Projet 6 MIC\PRODUCTS\template"
 
    'Add a slash at the end if the user forget it
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If
 
    'If there are no Excel files in the folder exit the sub
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If
 
    'Fill the array(myFiles)with the list of Excel files in the folder
    Fnum = 0
    Do While FilesInPath <> ""
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop
 
    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    'Loop through all files in the array(myFiles)
    If Fnum > 0 Then
        For Fnum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
            On Error GoTo 0
 
            If Not mybook Is Nothing Then
 
 
 
                    'Change cell value(s) in one worksheet in mybook
                    On Error Resume Next
 
                    With thisbook
                    If .ProtectContents = True Then
                        .Unprotect Password:=Pass
                        .Range("G17:L36").Select
                        Selection.Copy
                    End If
                End With
 
                    With mybook.Worksheets(1)
                    If .ProtectContents = True Then
                        .Unprotect Password:=Pass
                        .Range("G17:G36").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                        False, Transpose:=False
                        .Protect Password:=Pass
                    Else
                        .Range("G17:L36").Value = "erreur"
                        .Protect Password:=Pass
 
                    End If
 
                End With
 
 
                If Err.Number > 0 Then
                    ErrorYes = True
                    Err.Clear
                    'Close mybook without saving
                    mybook.Close savechanges:=False
                Else
                    'Save and close mybook
                    mybook.Close savechanges:=True
                End If
                On Error GoTo 0
            Else
                'Not possible to open the workbook
                ErrorYes = True
            End If
 
        Next Fnum
    End If
 
    If ErrorYes = True Then
        MsgBox "There are problems in one or more files, possible problem:" _
             & vbNewLine & "protected workbook/sheet or a sheet/range that not exist"
    End If
 
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

Si quelqu'un peut m'aider ça serait super gentil

Coordialement,

Antoine

[tamtam64]

Tu veux une macro pour copier la mise en forme d'une celulle? je peux te filer ca

[antoinepoirier]

Oui, enfin d'un groupe de cellules mais cela revient au même n'est-ce pas ?

De plus, il faut que ma maccro s'intègre à mon code d'ouverture de fichiers dans un dossier cible. J'ai mon code plus haut, je sais pas si tu l'as lu et si ça t'aide ?

Merci de la réponse,

[tamtam64]

Code :

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

1
2
3
4
5
    'applique un format
Sub Formatage(ByRef MyRange As Range, ByRef MyRangeRef as range)
 
        MyRangeRef.copy MyRange PasteSpecial Paste:=xlPasteFormats
End Su

je regarde ca et j'adapte mon code si tu veux

[antoinepoirier]

Donc ce que je dois faire :

J'ai un fichier A qui est ouvert. Je lance la macro, ce qui, en boucle, ouvre tous les fichiers X un par un d'un dossier cible. À chaque fichier X ouvert, ma macro va copier de G17 à L36 du fichier A et coller(spécial) dans le fichier X à la même place (G17 à L36). Ensuite enregistrer et fermer le fichier pour ouvrir le prochain, etc.

Mes feuilles sont protégées donc il faut les déverrouiller aussi.


Comme j'ai dit plus haut, la majeur partie est fonctionnelle, excepté le bout du copier coller d'un fichier à l'autre, je cherche la logique de jouer avec un fichier qu'on ne peut définir car il change (variable?)

[tamtam64]

Pardon je pensais que tu vouslais juste le format alors :

Code :

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

PasteSpecial Paste:=xlPasteAll

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
Option Explicit
 
Const Pass As String = "0179"
 
Sub Example()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String, Fnum As Long
    Dim mybook As Workbook, thisbook As Worksheet
 
        'Dim ActiveWorksheet As Worksheet
    Set thisbook = ActiveWorkbook.Sheets("Paramètres")
    Dim CalcMode As Long
    'Dim sh As Worksheet
    Dim ErrorYes As Boolean
 
    'Fill in the path\folder where the files are
    MyPath = "C:\Documents and Settings\apoirierrouillard\Bureau\Projet 6 MIC\PRODUCTS\template"
 
    'Add a slash at the end if the user forget it
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If
 
    'If there are no Excel files in the folder exit the sub
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If
 
    'Fill the array(myFiles)with the list of Excel files in the folder
    Fnum = 0
    Do While FilesInPath <> ""
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop
 
    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    'Loop through all files in the array(myFiles)
    If Fnum > 0 Then
        For Fnum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
            On Error GoTo 0
 
            If Not mybook Is Nothing Then
 
 
 
                    'Change cell value(s) in one worksheet in mybook
                    On Error Resume Next
 
                    With thisbook
                    If .ProtectContents = True Then
                        .Unprotect Password:=Pass
                        .Range("G17:L36").Copy
                    End If
                End With
 
                    With mybook.Worksheets(1)
                    If .ProtectContents = True Then
                        .Unprotect Password:=Pass
                        .Range("G17:G36").PasteSpecial Paste:=xlPasteAll
                        .Protect Password:=Pass
                    Else
                        .Range("G17:L36").Value = "erreur"
                        .Protect Password:=Pass
 
                    End If
 
                End With
 
 
                If Err.Number > 0 Then
                    ErrorYes = True
                    Err.Clear
                    'Close mybook without saving
                    mybook.Close savechanges:=False
                Else
                    'Save and close mybook
                    mybook.Close savechanges:=True
                End If
                On Error GoTo 0
            Else
                'Not possible to open the workbook
                ErrorYes = True
            End If
 
        Next Fnum
    End If
 
    If ErrorYes = True Then
        MsgBox "There are problems in one or more files, possible problem:" _
             & vbNewLine & "protected workbook/sheet or a sheet/range that not exist"
    End If
 
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

A priori ca marche t'as un msg d'erreur? donne le mois

[antoinepoirier]

Erreur '1004' : La méthode Select de la classe Range a échoué.