Utiliser une macro d'un fichier excell pour mettre en page une autre fichier excell

**ab1to** · 13/11/2013, 17h47

Bonjour,

J'aimerais utiliser un fichier excell 'de base' contenant une macro qui de mettre en page d'autres fichiers.

La raison est que j'ai plus de 1000 fichiers excell contenant un tableau que je voudrais mettre en page.

Mon fichier 'de base' doit me permettre d'ouvrir ces fichiers, de mettre en page le tableau (couleurs, font, ...) et de les sauver.

Je n'ai pas de problème pour ouvrir les 100 fichiers, mais je n'arrive pas à travailler dedans.

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
Sub testtab()

Dim xlapp As Excel.Application
Dim xlWbk As Excel.Workbook
Dim xlWsh, xlWsh2 As Excel.Worksheet
Dim Path, Path2 As String
Dim Ndossier, Nfichier, Nsheet, NivSeg As String
Dim Beginline, Endline, NumTab As Integer

'Référence dans mon fichier de base

Set xlapp = CreateObject("Excel.Application")

xlapp.DisplayAlerts = False

Sheets("Liste_Tables").Select

Beginline = 2

If Range("A" & Beginline).Offset(1, 0).Value <> "" Then
    Endline = Range("A" & Beginline).End(xlDown).Row
Else
    Endline = Beginline
End If

For NumTab = Beginline To Endline


Ndossier = Range("A" & NumTab).Value
Nfichier = Range("B" & NumTab).Value
Nsheet = Range("C" & NumTab).Value
NivSeg = Range("D" & NumTab).Value

Path2 = Ndossier & Nfichier & ".xlsx"

'Ouverture de mon fichier à modifier avec la macro

Set xlWbk = xlapp.Workbooks.Open(Path2)
xlapp.Visible = True

Set xlWsh = xlWbk.Worksheets(Nsheet)

xlWbk.Worksheets(Nsheet).Select

xlWbk.Worksheets(Nsheet).Rows("1:4").Delete

Dim FirstCol, LastCol, FirstCel, LastCel, TabCel As Integer

FirstCol = 1
LastCol = xlWbk.Worksheets(Nsheet).Cells(NivSeg + 1, FirstCol).End(xlToRight).Column
LastCel = xlWbk.Worksheets(Nsheet).Range("A65536").End(xlUp).Row

'Font
xlWbk.Worksheets(Nsheet).Range(Cells(1, 1), (Cells(LastCel, LastCol))).Select
With Selection.Font
    .Name = "Tahoma"
    .Size = 8
    .Bold = False
    .Italic = False
    .Color = RGB(97, 96, 101)
End With


Next

xlapp.DisplayAlerts = True
End Sub

J'arrive à supprimer des lignes, mais je ne sais pas comment aller plus loin (modifier le font, les couleus, ...), car j'ai besoin de pouvoir travailler dans la sheet ACTIVE.
Ma seule question est donc :
Comment puis-je faire pour travailler dans la sheet Nsheet de ce fichier comme dans une sheet de mon fichier de base ?

Merci d'avance pour votre aide.

Anthony

**EngueEngue** · 13/11/2013, 17h58

Ne jamais selectionner... c'est inutile..

Code :

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

1
2
3
4
5
6
7
8
xlWbk.Worksheets(Nsheet).Range(Cells(1, 1), (Cells(LastCel, LastCol))).Select
With Selection.Font
    .Name = "Tahoma"
    .Size = 8
    .Bold = False
    .Italic = False
    .Color = RGB(97, 96, 101)
End With

Code :

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

1
2
3
4
5
6
7
With xlWbk.Worksheets(Nsheet).Range(Cells(1, 1), (Cells(LastCel, LastCol))).font
.Name = "Tahoma"
    .Size = 8
    .Bold = False
    .Italic = False
    .Color = RGB(97, 96, 101)
End With

**ab1to** · 14/11/2013, 09h23

Merci pour cette info, mais j'ai essayé et je reçois le message d'erreur suivant :

Run-time error '1004'
Application-defined or object-defined error

Avez-vous une idée ?

Anthony

**EngueEngue** · 14/11/2013, 09h37

peux tu envoyer ton fichier macro plus le premier fichier de la liste dans un zip?

**ab1to** · 14/11/2013, 12h02

Voici mes fichiers.

Je dois aussi colorer les cellules sur base de conditions, encadrer les cellules, ... . Mais je pense que si je peux adapter le font, je pourrai aussi faire le reste.

Merci d'avance.

Anthony

**EngueEngue** · 14/11/2013, 13h27

Code :

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

1
2
3
4
5
6
7
With xlWbk.Worksheets(Nsheet).Range(xlWbk.Worksheets(Nsheet).Cells(1, 1), xlWbk.Worksheets(Nsheet).Cells(3, 5)).Font
    .Name = "Tahoma"
    .Size = 8
    .Bold = False
    .Italic = False
    .Color = RGB(97, 96, 101)
End With

**nibledispo** · 14/11/2013, 15h10

Bonjour,

Ci joint ton code que je crois mieux conçu.

Pour la font il faut mettre range("a1:e3") en lieu et place de range(cells(.....
Ne me demande pas pourquoi, je n'en sais rien!
autre chose : dans une déclaration dim les variables peuvent se succéder séparées par une virgule mais chacune doit néanmoins être suivi de son type faute de quoi elles sont de type variant à l'exception de la dernière.

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 testtab()
 
Dim xlapp As Excel.Application
Dim xlWbk As Excel.Workbook
Dim xlWsh As Worksheet, xlWsh2 As Excel.Worksheet
Dim Path2 As String  'Path As String,
Dim Ndossier As String, Nfichier As String, Nsheet As String, NivSeg As String
Dim Beginline As Integer, Endline As Integer, NumTab As Integer
Dim FirstCol As Integer, LastCol As Integer, FirstCel As Integer, LastCel As Integer, TabCel As Integer
 
'Path = "M:\Spss\13f2\AB\13f2_Macro Base.xlsm"
 
Set xlapp = CreateObject("Excel.Application")
'Set xlWbk = xlapp.Workbooks.Open(Path)
 
xlapp.DisplayAlerts = False
 
'Set xlWsh = xlWbk.Worksheets("Liste_Tables")
With Sheets("Liste_Tables")
    Beginline = 2
    If Range("A" & Beginline).Offset(1, 0).Value <> "" Then
       Endline = Range("A" & Beginline).End(xlDown).Row
    Else
       Endline = Beginline
    End If
 
    For NumTab = Beginline To Endline
        Ndossier = Range("A" & NumTab).Value
        Nfichier = Range("B" & NumTab).Value
        Nsheet = Range("C" & NumTab).Value
        NivSeg = Range("D" & NumTab).Value
 
        Path2 = Ndossier & Nfichier & ".xlsx"
 
        Set xlWbk = xlapp.Workbooks.Open(Path2)
        xlapp.Visible = True
 
        Set xlWsh = xlWbk.Worksheets(Nsheet)
 
        With xlWsh
            .Rows("1:4").Delete
            FirstCol = 1
            LastCol = .Cells(NivSeg + 1, FirstCol).End(xlToRight).Column
            LastCel = .Range("A65536").End(xlUp).Row
 
            With .Range("a1:e3").Font
                .Name = "Tahoma"
                .Size = 8
                .Bold = False
                .Italic = False
                .Color = RGB(97, 96, 101)
            End With
        End With
    Next
End With
xlapp.DisplayAlerts = True
 
End Sub

Cordialement,

**EngueEngue** · 14/11/2013, 15h23

Les deux marchent nible, il suffit de mettre un . devant le cells

**nibledispo** · 14/11/2013, 15h36

Bonjour Engue Engue,

j'ai vraiment la tête qui part en vrille avec l'âge.
Il y a peine une semaine Caseyfere (peut être mauvais orthographe) me signalait ce point sur un post que nous suivions et malgré cela je n'ai pas percuté sur cette discussion. (-1)
J'espère que cette fois c'est bien rentré dans ma caboche.

cordialement

**PMO2017** · 14/11/2013, 21h09

Bonjour,

Une piste avec votre code modifié qui crée une copie du classeur avec un préfixe "zzz_" (on préserve ainsi le classeur source).

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
Sub testtab()
Dim WB As Workbook
Dim S1 As Worksheet
Dim S2 As Worksheet
Dim R As Range
Dim Ndossier As String
Dim Nfichier As String
Dim Nsheet As String
Dim NivSeg As String
Dim Beginline As Long
Dim Endline As Long
Dim NumTab As Long
Dim LastCol As Long
 
Set S1 = Sheets("Liste_Tables")
Beginline = 2
Endline = S1.Range("A1").CurrentRegion.Rows.Count
 
For NumTab = Beginline To Endline
  Ndossier = S1.Range("A" & NumTab)
  Nfichier = S1.Range("B" & NumTab)
  Nsheet = S1.Range("C" & NumTab)
  NivSeg = S1.Range("D" & NumTab)
  '---
  Set WB = Workbooks.Open(Ndossier & Nfichier & ".xlsx")
  Set S2 = WB.Worksheets(Nsheet)
  S2.Rows("1:4").Delete
 
  LastCol = S2.Cells(NivSeg + 1, 1).End(xlToRight).Column
 
  Set R = S2.Range(Cells(1, 1), Cells(3, LastCol))
  '--- Font ---
  With R.Font
    .Name = "Tahoma"
    .Size = 8
    .Bold = False
    .Italic = False
    .Color = RGB(97, 96, 101)
  End With
  '--- Interior ---
  With R.Interior
    .Color = RGB(255, 255, 204)
  End With
  '--- etc ---
  '...
 
  '--- Copie du classeur avec un préfixe zzz_ (on ne touche pas au classeur source) ---
  WB.SaveCopyAs (Ndossier & "zzz_" & Nfichier & ".xlsx")
  '--- Ferme le classeur source sans sauvegarder ---
  WB.Close SaveChanges:=False
Next NumTab
 
End Sub

**ab1to** · 29/11/2013, 15h55

Super!
Merci à tous.

Voici ma macro qui fonctionne bien maintenant:

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
Sub testtab()
 
Dim xlapp As Excel.Application
Dim xlWbk As Excel.Workbook
Dim xlWsh As Worksheet, xlWsh2 As Excel.Worksheet
Dim Path As String, PathSave As String
Dim Ndossier As String, Nfichier As String, Nsheet As String, NivSeg As String, QLoc As String
Dim Beginline As Integer, Endline As Integer, NumTab As Integer
Dim FirstCol As Integer, LastCol As Integer, FirstCel As Integer, LastCel As Integer, TabCel As Integer
Dim AVGeng As Integer
Dim mycel As Excel.Range
Dim SheetNum As Byte
Dim Nmin As Integer
 
Set xlapp = CreateObject("Excel.Application")
 
xlapp.DisplayAlerts = False
 
With Sheets("Liste_Tables")
    Beginline = 2
    If Range("A" & Beginline).Offset(1, 0).Value <> "" Then
       Endline = Range("A" & Beginline).End(xlDown).Row
    Else
       Endline = Beginline
    End If
 
    'Loop Nbre de fichiers
    For NumTab = Beginline To Endline
        Ndossier = Range("A" & NumTab).Value
        Nfichier = Range("B" & NumTab).Value
        NivSeg = Range("C" & NumTab).Value
        QLoc = Range("D" & NumTab).Value
 
        Path = Ndossier & "TB_Export\" & Nfichier & ".xlsx"
        PathSave = Ndossier & "TB_Layout\RP Survey_" & Nfichier & " 2013.xlsx"
 
        Set xlWbk = xlapp.Workbooks.Open(Path)
        xlapp.Visible = True
 
 
    'Loop Sheets
    For SheetNum = 1 To xlapp.Sheets.Count
 
        Set xlWsh = xlWbk.Worksheets(SheetNum)
 
        With xlWsh
            .Rows("1:4").Delete
            .Columns("B:B").Delete
            FirstCol = 1
            LastCol = .Cells(NivSeg + 1, FirstCol).End(xlToRight).Column
            LastCel = .Range("A65536").End(xlUp).Row
 
            With .Rows("1:65536")
                With .Font
                        .Name = "Tahoma"
                        .Size = 8
                        .Bold = False
                        .Italic = False
                        .Color = RGB(97, 96, 101)
                End With
                With .Cells
                    .VerticalAlignment = xlCenter
                    .HorizontalAlignment = xlCenter
 
                End With
            End With
            With .Columns("A:A").Cells
                    .HorizontalAlignment = xlLeft
            End With
            .Rows(NivSeg + 2 & ":" & NivSeg + 3).Font.Bold = True
            .Rows(NivSeg + 8 & ":" & NivSeg + 8).Font.Bold = True
            If QLoc = "Y" Then
            .Rows(NivSeg + 16 & ":" & NivSeg + 16).Font.Bold = True
            End If
 
            'Cadre
            With .Range(.Cells(1, 1), .Cells(LastCel, LastCol)).Borders
                .LineStyle = xlContinuous
                .Weight = xlThin
                .Color = RGB(79, 129, 189)
            End With
 
 
            'Format Columns & Rows
            .Columns("A:A").WrapText = False
            .Columns.ColumnWidth = 10
            .Columns("A:A").EntireColumn.AutoFit
            .Rows("1:" & LastCel + 4).Rows.RowHeight = 10.5
            .Rows("1:" & NivSeg).EntireRow.AutoFit
 
            'Moyenne pondérée (Overall engagement)
            For AVGeng = 2 To LastCol
            .Cells(5, AVGeng).Value = .Cells(6, AVGeng).Value * 0.14 + _
                                      .Cells(7, AVGeng).Value * 0.26 + _
                                      .Cells(8, AVGeng).Value * 0.14 + _
                                      .Cells(9, AVGeng).Value * 0.46
            Next AVGeng
 
            'Couleurs cellules
            For Each mycel In .Range(.Cells(NivSeg + 2, 2), .Cells(LastCel, LastCol))
                If mycel.Value <> "." And mycel.Value <> "99999" And mycel.Value <> "88888" Then
                            mycel.Value = Round((mycel.Value * 1), 1)
                    Select Case mycel.Value
                        Case Is = "": mycel.Interior.Pattern = xlNone
                        Case Is < 6.5
                            mycel.Interior.Color = RGB(255, 0, 0)
                            mycel.Font.Color = RGB(255, 255, 255)
                        Case 6.5 To 7.4
                            mycel.Interior.Color = RGB(255, 255, 0)
                            mycel.Font.Color = RGB(0, 0, 0)
                        Case Is > 7.4
                            mycel.Interior.Color = RGB(0, 255, 0)
                            mycel.Font.Color = RGB(0, 0, 0)
                    End Select
                ElseIf mycel.Value = "99999" Then
                    Select Case mycel.Value
                        Case Is = "99999": mycel.Interior.Pattern = xlNone
                            mycel.Value = ""
                    End Select
                ElseIf mycel.Value = "88888" Then
                    Select Case mycel.Value
                        Case Is = "88888": mycel.Interior.Pattern = xlNone
                            mycel.Value = "NA"
                    End Select
                End If
            Next
 
            'Suppression des résultats si n<5
            For Nmin = 2 To LastCol
                If .Cells(NivSeg + 1, Nmin).Value < 5 Then
                .Range(.Cells(NivSeg + 3, Nmin), .Cells(LastCel, Nmin)).Value = "NA"
                .Range(.Cells(NivSeg + 8, Nmin), .Cells(NivSeg + 8, Nmin)).Value = ""
                .Range(.Cells(NivSeg + 3, Nmin), .Cells(LastCel, Nmin)).Font.Color = RGB(97, 96, 101)
                .Range(.Cells(NivSeg + 3, Nmin), .Cells(LastCel, Nmin)).Interior.Color = xlNone
                If QLoc = "Y" Then
                .Range(.Cells(NivSeg + 16, Nmin), .Cells(NivSeg + 16, Nmin)).Value = ""
                End If
            End If
            Next Nmin
 
 
            'Légende
            With .Range(.Cells(LastCel + 2, 1), .Cells(LastCel + 2, 1))
                    .Value = "High score >7.4"
                    With .Font
                        .Color = RGB(0, 0, 0)
                    End With
                    .Interior.Color = RGB(0, 255, 0)
            End With
            With .Range(.Cells(LastCel + 3, 1), .Cells(LastCel + 3, 1))
                    .Value = "Medium score 6.5-7.4"
                    With .Font
                        .Color = RGB(0, 0, 0)
                    End With
                    .Interior.Color = RGB(255, 255, 0)
            End With
            With .Range(.Cells(LastCel + 4, 1), .Cells(LastCel + 4, 1))
                    .Value = "Low score <6.5"
                    With .Font
                        .Color = RGB(255, 255, 255)
                    End With
                    .Interior.Color = RGB(255, 0, 0)
            End With
            With .Range(.Cells(LastCel + 2, 1), .Cells(LastCel + 4, 1))
                    With .Borders
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .Color = RGB(79, 129, 189)
                    End With
            End With
        End With
 
    Next SheetNum
 
    'Copie du fichier tableau spss
    xlWbk.SaveCopyAs (PathSave)
    xlWbk.Close SaveChanges:=False
 
    Next
 
End With
 
xlapp.DisplayAlerts = True
 
End Sub

Je voudrais juste encore savoir comment identifier le numéro de la ligne qui correspond à une cellule contenant le texte "Total n" qui se trouve dans la colonne A. J'aurais besoin de cette info, car le nombre de ligne jusque cette cellule peut varier.

Merci encore.

Anthony

**Marc-L** · 29/11/2013, 16h25

Bonjour,

voir l'aide de la méthode Find et son exemple pour trouver la cellule
(plus simple avec une cellule nommée, pas besoin alors de la chercher !)
et c'est la propriété Row pour le numéro de la ligne …

__________________________________________________________________________________________

Merci de cliquer sur

pour chaque message ayant aidé puis sur

pour clore cette discussion …

**PMO2017** · 29/11/2013, 16h40

Bonjour,

Quelque chose comme suit

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
'/// extrait de votre code
    For SheetNum = 1 To xlapp.Sheets.Count
 
        Set xlWsh = xlWbk.Worksheets(SheetNum)
 
        With xlWsh
            .Rows("1:4").Delete
'### ajout
Dim Range_Totaln As Range
Set Range_Totaln =  .Columns(1).Find(What:="Total n")
If Not Range_Totaln Is Nothing Then
  MsgBox Range_Totaln.Row
Else
  MsgBox "La chaîne ''Total n'' n'a pas été trouvée"
End If
'###
 
'/// suite de votre code

Utiliser une macro d'un fichier excell pour mettre en page une autre fichier excell

Macros et VBA Excel

Discussions similaires

Partager

Partager