Conversion VBA -> Basic

**ancel17** · 19/03/2014, 11h49

Bonjour,

Je souhaite traduire ce code VBA en Basic car mon administration abandonne MS Office pour LibreOffice...

Je n'ai jamais codé autre chose que VBA et malgré mes recherches je suis fort démuni... J'avais bien pensé me servir de l'enregistreur de macro pour me faire une idée, mais il se limite aux actions faites sur la feuille de lancement... Or moi, j'ouvre d'autres classeurs, j'en crée un nouveau dans lequel j'importe certaines données des classeurs ouverts, les dispatche et les retraite sur différentes feuilles avant de faire un TCD... Donc en gros, l'enregistreur ne me donne rien...

Voici le code que je dois traduire :

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
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
Private Sub Workbook_Open()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim fso As New FileSystemObject
Dim Rep As Folder
Dim Fich As File
Dim Wb As Workbook, wbLot As Workbook, wbLiv As Workbook, wbNew As Workbook
Dim fl As Worksheet, fLot As Worksheet, fLiv As Worksheet, fNew As Worksheet, Sh As Worksheet
Dim c As Range, cLiv As Range
Dim wk As Variant
Dim nomFich As String, valTVA As String
Dim lgSh As Long, myRow As Long
 
Set Wb = ThisWorkbook
Set Rep = fso.GetFolder(Application.ThisWorkbook.Path & "\EXPORT")
Set fl = Wb.Worksheets(1)
fl.Unprotect "ma214248"
 
'------------------------------------------------------------------------------------------
'DEFINITION ET OUVERTURE DES FICHIERS - Pour chaque fichier du répertoire Rep, ouvrir les fichiers .xls contenant LOT ou LIV
'------------------------------------------------------------------------------------------
For Each Fich In Rep.Files
    wk = Rep & "\" & Fich.Name
    If fso.GetExtensionName(wk) = "xls" Then
        If Fich.Name Like "*LOT*" Then
            Set wbLot = Workbooks.Open(wk)
            Set fLot = wbLot.Worksheets(1)
            With fLot
                If .FilterMode = True Then fLot.ShowAllData
            End With
        ElseIf Fich.Name Like "*LIV*" Then
            Set wbLiv = Workbooks.Open(wk)
            Set fLiv = wbLiv.Worksheets(1)
            With fLiv
                If .FilterMode = True Then fLiv.ShowAllData
            End With
        End If
    End If
Next
Set wk = Nothing
Set Fich = Nothing
Set Rep = Nothing
'-----------------------------------------------------------------------------------------
'CREATION DU FICHIER DE SAUVEGARDE - Si le fichier de sauvegarde existe déjà, ou on remplace ou on en crée un nouveau
'-----------------------------------------------------------------------------------------
nomFich = Wb.Path & "\SAUVEGARDE\" & "LIC - " & fLiv.Range("C3").Value & ".xls"
If Not Dir(nomFich) = "" Then
Application.ScreenUpdating = True
    Select Case MsgBox("Le fichier " & "LIC - " & fLiv.Range("C3").Value & ".xls existe déjà." & vbLf & "Souhaitez-vous le remplacer (Oui) ou créer un nouveau fichier de sauvegarde (Non) ?", vbYesNo + vbQuestion, "Sauvegarde du fichier")
        Case vbYes
            Kill nomFich
        Case vbNo
            nomFich = Wb.Path & "\SAUVEGARDE\" & "LIC - " & fLiv.Range("C3").Value & " - " & Format(Now(), "yyyy.mm.dd hh.mm") & ".xls"
    End Select
Application.ScreenUpdating = False
End If
Set wbNew = Workbooks.Add
wbNew.SaveAs Filename:=nomFich, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
    ReadOnlyRecommended:=False, CreateBackup:=False
nomFich = vbNullString
'-----------------------------------------------------------------------------------------
'REMPLISSAGE FICHIER DE SAUVEGARDE
'-----------------------------------------------------------------------------------------
wbNew.Worksheets(1).Name = "Général"
wbNew.Worksheets(2).Name = "Rapport"
wbNew.Worksheets(3).Name = "Base de données"
Set fNew = wbNew.Worksheets("Base de données")
fl.Cells.Copy Destination:=fNew.Range("A1")
fNew.Columns("A:A").Insert xlToRight
fNew.Range("B1").Copy fNew.Range("A1")
fNew.Range("A1").Value = "Année"
Set fNew = wbNew.Worksheets("Général")
fl.Cells.Copy Destination:=fNew.Range("A1")
fLot.Range("B3:I" & fLot.Range("B" & Rows.Count).End(xlUp).Row).Copy
fNew.Range("A2").PasteSpecial (xlPasteValues)
wbLot.Close
For Each c In fNew.Range("A2:A" & fNew.Range("A" & Rows.Count).End(xlUp).Row).Cells
    For Each cLiv In fLiv.Range("D3:D" & fLiv.Range("D" & Rows.Count).End(xlUp).Row).Cells
        If (c.Value = cLiv.Value) And (cLiv.Offset(0, -2).Value Like "20*") Then
            c.Offset(0, 8).Value = c.Offset(0, 8).Value + cLiv.Offset(0, 1).Value
            c.Offset(0, 9).Value = c.Offset(0, 9).Value + cLiv.Offset(0, 2).Value
            c.Offset(0, 10).Value = c.Offset(0, 8).Value + c.Offset(0, 9).Value
            c.Offset(0, 11).Value = c.Offset(0, 11).Value + cLiv.Offset(0, 4).Value
            c.Offset(0, 12).Value = c.Offset(0, 10).Value + c.Offset(0, 11).Value
            Set Sh = wbNew.Worksheets("Base de données")
            lgSh = Sh.Range("A" & Sh.Rows.Count).End(xlUp).Row
            valTVA = Sh.Range("B" & lgSh).Value
            If Not Left(Sh.Cells(lgSh, c.Column).Value, 4) = Left(cLiv.Offset(0, -2).Value, 4) Or Not c.Value = valTVA Then
                lgSh = lgSh + 1
                Sh.Cells(lgSh, c.Column).Value = Left(cLiv.Offset(0, -2).Value, 4)
                Sh.Cells(lgSh, c.Column + 1).Value = c.Value
                Sh.Cells(lgSh, c.Column + 2).Value = c.Offset(0, 1).Value
                Sh.Cells(lgSh, c.Column + 3).Value = c.Offset(0, 2).Value
                Sh.Cells(lgSh, c.Column + 4).Value = c.Offset(0, 3).Value
                Sh.Cells(lgSh, c.Column + 5).Value = c.Offset(0, 4).Value
                Sh.Cells(lgSh, c.Column + 6).Value = c.Offset(0, 5).Value
                Sh.Cells(lgSh, c.Column + 7).Value = c.Offset(0, 6).Value
                Sh.Cells(lgSh, c.Column + 8).Value = c.Offset(0, 7).Value
            End If
            Sh.Cells(lgSh, c.Column + 9).Value = Sh.Cells(lgSh, c.Column + 9).Value + cLiv.Offset(0, 1).Value
            Sh.Cells(lgSh, c.Column + 10).Value = Sh.Cells(lgSh, c.Column + 10).Value + cLiv.Offset(0, 2).Value
            Sh.Cells(lgSh, c.Column + 11).Value = Sh.Cells(lgSh, c.Column + 9).Value + Sh.Cells(lgSh, c.Column + 10).Value
            Sh.Cells(lgSh, c.Column + 12).Value = Sh.Cells(lgSh, c.Column + 12).Value + cLiv.Offset(0, 4).Value
            Sh.Cells(lgSh, c.Column + 13).Value = Sh.Cells(lgSh, c.Column + 11).Value + Sh.Cells(lgSh, c.Column + 12).Value
        End If
    Next cLiv
Next c
lgSh = 0
Année = 0
wbLiv.Close
'-----------------------------------------------------------------------------------------
'MISE EN PAGE DU FICHIER DE SAUVEGARDE
'-----------------------------------------------------------------------------------------
For Each Sh In wbNew.Sheets
    Sh.Activate
    If Sh.Name = "Général" Or Sh.Name = "Base de données" Then
        If Sh.Name = "Général" Then
            Sh.Range("A1").CurrentRegion.Sort Key1:=Sh.Range("M1"), Order1:=xlDescending, Header:=xlYes
            Sh.Range("E1:F" & Sh.Range("A" & Sh.Rows.Count).End(xlUp).Row).HorizontalAlignment = xlCenter
            Sh.Range("I2:M" & Sh.Range("M" & Sh.Rows.Count).End(xlUp).Row).NumberFormat = "#,##0"
            Sh.Range("A1:M1").Select
        ElseIf Sh.Name = "Base de données" Then
            Sh.Range("A1").CurrentRegion.Sort Key1:=Sh.Range("A1"), Order1:=xlDescending, key2:=Sh.Range("N1"), order2:=xlDescending, Header:=xlYes
            Sh.Range("A1").CurrentRegion.VerticalAlignment = xlCenter
            Union(Sh.Range("A1:A" & Sh.Range("A" & Sh.Rows.Count).End(xlUp).Row), Sh.Range("F1:G" & Sh.Range("A" & Sh.Rows.Count).End(xlUp).Row)).HorizontalAlignment = xlCenter
            Sh.Range("J2:N" & Sh.Range("N" & Sh.Rows.Count).End(xlUp).Row).NumberFormat = "#,##0"
            Sh.Range("A1:N1").Select
            Selection.AutoFilter
        End If
        ActiveWindow.Zoom = True
        Sh.Range("A2").Select
        ActiveWindow.FreezePanes = True
        Sh.Range("A1").Select
    End If
Next Sh
'-----------------------------------------------------------------------------------------
'CREATION RAPPORT - Création du tableau croisé dynamique, copier/coller valeur, mise en forme
'-----------------------------------------------------------------------------------------
wbNew.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
    ['Base de données'!A1].CurrentRegion.Address(, , xlR1C1, True)).CreatePivotTable _
    TableDestination:=wbNew.Worksheets("Rapport").Range("A1"), TableName:="Rapport TCD"
Set fNew = wbNew.Worksheets("Rapport")
fNew.PivotTables("Rapport TCD").SmallGrid = False
fNew.PivotTables("Rapport TCD").AddFields RowFields:=Array("Numéro TVA", "Vérif.", "Nom", "Données"), ColumnFields:="Année"
With fNew.PivotTables("Rapport TCD").PivotFields("Montant Biens")
    .Orientation = xlDataField
    .Position = 1
End With
With fNew.PivotTables("Rapport TCD").PivotFields("Montant Triangul.")
    .Orientation = xlDataField
    .Position = 2
End With
With fNew.PivotTables("Rapport TCD").PivotFields("Total Biens")
    .Orientation = xlDataField
   .Position = 3
End With
With fNew.PivotTables("Rapport TCD").PivotFields("Montant services")
    .Orientation = xlDataField
    .Position = 4
End With
fNew.PivotTables("Rapport TCD").PivotFields("TOTAL").Orientation = xlDataField
With fNew.PivotTables("Rapport TCD").PivotFields("Données")
    .Orientation = xlColumnField
    .Position = 2
End With
fNew.Range("B5").Delete
fNew.Range("A5").Delete
Application.CommandBars("PivotTable").Visible = False
fNew.Activate
fNew.Cells.Select
With Selection.Font
    .Name = "Arial"
    .Size = 8
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ColorIndex = xlAutomatic
End With
fNew.Columns("A:A").EntireColumn.AutoFit
fNew.Columns("B:B").EntireColumn.AutoFit
fNew.Columns("C:C").ColumnWidth = 35
fNew.Columns("D:AB").ColumnWidth = 8
With Selection
    .HorizontalAlignment = xlGeneral
    .VerticalAlignment = xlCenter
    .WrapText = True
    .Orientation = 0
    .AddIndent = False
    .ShrinkToFit = False
    .MergeCells = False
End With
fNew.Cells.Copy
fNew.Range("A1").PasteSpecial (xlValues)
fNew.Range("A3").ClearContents
fNew.Range("A3").Value = "Numéro TVA"
fNew.Range("B3").ClearContents
fNew.Range("B3").Value = "Vérif."
fNew.Range("C3").ClearContents
fNew.Range("C3").Value = "Nom"
fNew.Range("A2:AB3").Font.Bold = True
fNew.Rows("1:1").Delete xlUp
fNew.Range("AB1").Cut Destination:=fNew.Range("AB2")
fNew.Range("AA1").Cut Destination:=fNew.Range("AA2")
fNew.Range("X1:Z1").Cut Destination:=fNew.Range("X2:Z2")
fNew.Range("W1").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlcontinous
    .Weight = xlThin
    .ColorIndex = 2
End With
With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = 1
End With
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = 1
End With
With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
End With
Union(fNew.Range("AB3:AB" & fNew.Range("AB" & fNew.Rows.Count).End(xlUp).Row), fNew.Range("W3:W" & fNew.Range("W" & fNew.Rows.Count).End(xlUp).Row), _
    fNew.Range("R3:R" & fNew.Range("R" & fNew.Rows.Count).End(xlUp).Row), fNew.Range("M3:M" & fNew.Range("M" & fNew.Rows.Count).End(xlUp).Row), _
    fNew.Range("H3:H" & fNew.Range("H" & fNew.Rows.Count).End(xlUp).Row)).Font.Bold = True
fNew.Range("A" & fNew.Range("A" & fNew.Rows.Count).End(xlUp).Row & ":AB" & fNew.Range("A" & fNew.Rows.Count).End(xlUp).Row).Font.Bold = True
fNew.Range("D3").Select
ActiveWindow.FreezePanes = True
fNew.Range("D3:AB" & fNew.Range("A" & fNew.Rows.Count).End(xlUp).Row).NumberFormat = "#,##0"
fNew.Range("A2:AB" & fNew.Range("A" & fNew.Rows.Count).End(xlUp).Row - 1).Sort Key1:=fNew.Range("AB3"), Order1:=xlDescending, Header:=xlGuess _
    , OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
fNew.Range("A2").Select
'----------------------------------------------------------------------------------------------------------------------------
'ZONE D'IMPRESSION CLASSEUR DE SAUVEGARDE - paysage, ajuster à 1 feuille en largeur, 1cm de marge, répéter les lignes 1 et 2 pour le rapport et 1 pour les autres feuille
'----------------------------------------------------------------------------------------------------------------------------
For Each Sh In wbNew.Sheets
    With Sh.PageSetup
        If Sh.Name = "Rapport" Then
            .PrintTitleRows = "$1:$2"
        Else
            .PrintTitleRows = "$1:$1"
        End If
        .PrintTitleColumns = ""
        .PrintArea = ""
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.393700787401575)
        .RightMargin = Application.InchesToPoints(0.393700787401575)
        .TopMargin = Application.InchesToPoints(0.393700787401575)
        .BottomMargin = Application.InchesToPoints(0.393700787401575)
        .HeaderMargin = Application.InchesToPoints(0.393700787401575)
        .FooterMargin = Application.InchesToPoints(0.393700787401575)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
    End With
Next Sh
'-----------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------
wbNew.Worksheets("Général").Activate
fl.Protect "ma214248"
Set fso = Nothing
Set wbLot = Nothing
Set wbLiv = Nothing
Set wbNew = Nothing
Set fl = Nothing
Set fLot = Nothing
Set fLiv = Nothing
Set Sh = Nothing
Set c = Nothing
Set cLiv = Nothing
Set wk = Nothing
Wb.Close
Set Wb = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Si des bonnes âmes veulent bien me secourir, je leur en serai très reconnaissant !

Merci de votre aide !

**zoom61** · 19/03/2014, 19h08

Salut,

Si tu veux faire des applications pro, je te conseille cet ouvrage Programmation OpenOffice.org et LibreOffice.

Ensuite, comme tu pourras le voir la programmation VBA et OBasic sont vraiment différentes... il va donc te falloir de la patience.

@+.

**ancel17** · 26/03/2014, 16h38

Intéressant, si la direction accepte de l'acheter, je pourrai peut-être m'en sortir...

Conversion VBA -> Basic

OpenOffice & LibreOffice

Discussions similaires

Partager

Partager