Pièce jointe « coda-excel-vba.txt »
Téléchargement 1 Sub Auto_Open()
2 ' InstallToolbarReflets
3 End Sub
4 '
5 ' Créé le 02/09/2002 par Andrei Boyanov <andrei.boyanov@auf.org>
6 ' Repris le 05/09/2002 par Jean Christophe André <jean-christophe.andre@auf.org>
7 '
8 Sub InstallToolbarReflets()
9 If (is_bar_installed("Reflets") = False) Then
10 Set barReflets = CommandBars.Add(name:="Reflets", Position:=msoBarTop)
11 Set buttonReflets1 = barReflets.Controls.Add(Type:=msoControlButton)
12 Set buttonReflets2 = barReflets.Controls.Add(Type:=msoControlButton)
13
14 buttonReflets1.Caption = "CODA-Détails"
15 buttonReflets1.DescriptionText = "Collage d'une interro-détails CODA à partir de TSE"
16 buttonReflets1.Style = msoButtonCaption
17 buttonReflets1.OnAction = "CODA_DETAILS"
18
19 buttonReflets2.Caption = "CODA-Cumuls"
20 buttonReflets2.DescriptionText = "Collage d'une interro-cumuls CODA à partir de TSE"
21 buttonReflets2.Style = msoButtonCaption
22 buttonReflets2.OnAction = "CODA_CUMULS"
23
24 barReflets.Visible = True
25 End If
26 ' MsgBox ("Installation avec succès")
27 End Sub
28
29 Function is_bar_installed(name As Variant)
30 For Each bar In CommandBars
31 If (bar.name = name) Then
32 is_bar_installed = True
33 Exit Function
34 End If
35 Next
36 is_bar_installed = False
37 Exit Function
38 End Function
39
40 Function is_sheet_installed(name As Variant)
41 For Each ws In Worksheets
42 If (ws.name = name) Then
43 is_sheet_installed = True
44 Exit Function
45 End If
46 Next
47 is_sheet_installed = False
48 Exit Function
49 End Function
50
51 '
52 ' Créé le 02/09/2002 par Andrei Boyanov <andrei.boyanov@auf.org>
53 '
54 Sub RemoveToolbarReflets()
55 ' MsgBox "Je vais supprimer le bouton et la barre d'outils Reflets"
56 CommandBars("Reflets").Delete
57 End Sub
58
59 '
60 ' Créé le ??/08/2002 par CODA ? Van-Thong Souy ?
61 '
62 Sub CODA_DETAILS()
63 Dim w As Worksheet
64 Dim r As Range
65 Dim MaVariable As String
66 Dim i As Integer
67 Dim j As Integer
68
69 ' changements par JCA
70 ' Set w = Worksheets(ActiveWorkbook.ActiveSheet.name)
71 If (is_sheet_installed("CODA-Détails") = False) Then
72 Set w = Worksheets.Add
73 w.name = "CODA-Détails"
74 Else
75 Set w = Worksheets("CODA-Détails")
76 End If
77 w.Paste Destination:=w.Range("A1:AT60000")
78 Set r = w.Range("A2:AT60000")
79 ' fin des changements par JCA
80
81 i = 1
82 While Not i = 60001
83 j = 1
84 While Not j = 46
85
86 If j = 1 Then
87 ' test des 5 premières colonnes
88 If IsEmpty(r.Cells(i, 1)) And IsEmpty(r.Cells(i, 2)) And IsEmpty(r.Cells(i, 3)) And IsEmpty(r.Cells(i, 4)) And IsEmpty(r.Cells(i, 5)) Then
89 Exit Sub
90 End If
91 End If
92
93 If Not IsEmpty(r.Cells(i, j)) Then
94 ' recuperation de la valeur et modification
95 MaVariable = (r.Cells(i, j).Text)
96
97 ' affichage du 'nombre' créé (on force avec une multiplication par 1)
98 r.Cells(i, j).Select
99 If Selection.NumberFormat = "General" And IsNumeric(MaVariable) Then
100 If Not MaVariable = "#DEV!" Then
101 If Not Selection.NumberFormat = "m/d/yy" Or Not Selection.NumberFormat = "hh:mm:ss" Then
102 r.Cells(i, j).Replace What:=",", Replacement:=",", LookAt:=xlPart, SearchOrder:= _
103 xlByRows, MatchCase:=False
104 ActiveCell.FormulaR1C1 = MaVariable * 1
105 End If
106 End If
107 End If
108 If Selection.NumberFormat = "General" Then
109 If InStr(1, r.Cells(i, j).Text, ".") Then
110 If InStr(1, r.Cells(i, j).Text, ",") Then
111 If Not InStr(1, r.Cells(i, j).Text, "-") Then
112 r.Cells(i, j).Replace What:=".", Replacement:="", LookAt:=xlPart, SearchOrder:= _
113 xlByRows, MatchCase:=False
114 r.Cells(i, j).Select
115 If IsNumeric(r.Cells(i, j).Text) Then
116 ActiveCell.FormulaR1C1 = r.Cells(i, j).Text * 1
117 End If
118 End If
119 End If
120 End If
121 End If
122
123 End If
124
125 j = j + 1
126 Wend
127 i = i + 1
128 Wend
129 End Sub
130
131 '
132 ' Créé le ??/08/2002 par CODA ? Van ?
133 '
134 Sub CODA_CUMULS()
135 Dim w As Worksheet
136 Dim r As Range
137 Dim MaVariable As String
138 Dim i As Integer
139 Dim j As Integer
140
141 ' changements par JCA
142 ' Set w = Worksheets(ActiveWorkbook.ActiveSheet.name)
143 If (is_sheet_installed("CODA-Cumuls") = False) Then
144 Set w = Worksheets.Add
145 w.name = "CODA-Cumuls"
146 Else
147 Set w = Worksheets("CODA-Cumuls")
148 End If
149 w.Paste Destination:=w.Range("A1:J60000")
150 Set r = w.Range("B1:J60000")
151 ' fin des changements par JCA
152
153 i = 1
154 While Not i = 60001
155 j = 1
156 While Not j = 10
157
158 If Not IsEmpty(r.Cells(i, j)) Then
159 ' recuperation de la valeur et modification
160 MaVariable = Trim(r.Cells(i, j).Text)
161
162 ' affichage du 'nombre' créé (on force avec une multiplication par 1)
163 r.Cells(i, j).Select
164 If IsNumeric(r.Cells(i, j).Text) Then
165 ActiveCell.FormulaR1C1 = MaVariable * 1
166 End If
167 Else
168 If j = 1 Then
169 Cells.Select
170 Range("A23").Activate
171 Selection.Columns.AutoFit
172
173 Exit Sub
174 End If
175 End If
176
177 j = j + 1
178 Wend
179 i = i + 1
180 Wend
181
182 Cells.Select
183 Range("A23").Activate
184 Selection.Columns.AutoFit
185 End Sub
Fichiers joints
Pour vous référer aux pièces jointes d'une page, utilisez attachment:filename, comme indiqué ci-dessous dans la liste de fichiers. N'utilisez pas l'URL du lien [get], car elle peut changer et donc être facilement cassée.Vous n'êtes pas autorisé à joindre un fichier à cette page.