VBACodeBank/Module.bas at main · slang5/VBACodeBank · GitHub

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
SubTurnOffDuringProcess(App AsApplication, IsEnd AsBoolean)
With App
If IsEnd <> TrueThen
 .ScreenUpdating = False
 .Calculation = xlCalculationManual
Else
 .ScreenUpdating = True
 .Calculation = xlCalculationAutomatic
End If
End With
End Sub

SubFaireUnExtract()
Dim SQL AsNew SQL_InVBA
 SQL.Class_Initialize
 SQL.ConnectionDB DB_Mapping.Range("PATH2")
 SQL.DesignRequest "Date", "Sheet1"
 SQL.AddToRequest " WHERE Famille = 'DS'"
 SQL.ExecuteRequest
 SQL.CloseDB

CallArrayToRange(OutPut, "A1", SQL.matriceGlobale, True)

Dim matriceDates() AsVariant
CallArrayToTransposedArray(SQL.matriceGlobale, matriceDates)
Dim countdate AsInteger
 countdate = GetCountDatesHowAnotherdate(matriceDates, Date)

CallArrayToRange(OutPut, "D1", matriceDates, False)

End Sub

SubArrayToRange(ws AsWorksheet, location AsString, matrice AsVariant, transpose AsBoolean) 'Easy : placer une matrice dans un worksheet
Dim Lignes AsInteger
Dim Colonnes AsInteger

 Lignes = IIf(UBound(matrice, 1) = 0, 1, UBound(matrice, 1)) - 1
 Colonnes = IIf(UBound(matrice, 2) = 0, 1, UBound(matrice, 2)) - 1
If transpose = FalseThen
 ws.Range(ws.Range(location), ws.Range(location).Offset(Lignes, Colonnes)).ClearContents
 ws.Range(ws.Range(location), ws.Range(location).Offset(Lignes, Colonnes)) = matrice
ElseIf transpose = TrueThen
 ws.Range(ws.Range(location), ws.Range(location).Offset(Colonnes, Lignes)).ClearContents
 ws.Range(ws.Range(location), ws.Range(location).Offset(Colonnes, Lignes)) = WorksheetFunction.transpose(matrice)
End If

End Sub

SubArrayToTransposedArray(arrayStart AsVariant, arrayEnd AsVariant)
Dim ligne AsInteger
Dim Colonne AsInteger

 arrayEnd = WorksheetFunction.transpose(arrayStart)
End Sub

FunctionGetCountDatesHowAnotherdate(matrice AsVariant, ComparaisonDate AsDate) 'avoir un decompte des dates supérieures (>) à une autre date

 GetCountDatesHowAnotherdate = GetCountDatesHowAnotherdateWithSpecifiedColumn(matrice, ComparaisonDate, 1)

End Function


FunctionGetCountDatesHowAnotherdateWithSpecifiedColumn(matrice AsVariant, ComparaisonDate AsDate, Colonne AsInteger) ' permet d'analyser les lignes qui représentent des dates et savoir lesquelles sont > à une certaine date
Dim count AsInteger
Dim ligne AsInteger
Dim iter AsInteger

 count = 0
 ligne = UBound(matrice, 1)

For iter = 1To ligne
If CDate(matrice(iter, Colonne)) > CDate(ComparaisonDate) Then
 count = count + 1
End If
Next iter
 GetCountDatesHowAnotherdate = count

End Function

FunctionTurnUSDateIntoEUDate(texte AsString) 'permet de traduire ce qui est écrit dans l'extraction ICE
 TurnUSDateIntoEUDate = Right(Left(texte, 5), 2) & "/" & Right(texte, 2) & "/" & Right(texte, 4)
End Function

FunctionQuantiteParFixingAndLeverage(quantite1 AsDouble, quantite2 AsDouble)
Dim matriceretour() AsDouble
ReDim matriceretour(1To3) AsDouble
If quantite1 > quantite2 Then
 matriceretour(1) = quantite2
 matriceretour(2) = quantite1
 matriceretour(3) = matriceretour(2) / matriceretour(1)
ElseIf quantite1 < quantite2 Then
 matriceretour(1) = quantite1
 matriceretour(2) = quantite2
 matriceretour(3) = matriceretour(2) / matriceretour(1)
ElseIf quantite1 = quantite2 Then
 matriceretour(1) = quantite2
 matriceretour(2) = quantite1
 matriceretour(3) = 1
End If
 QuantiteParFixingAndLeverage = matriceretour
End Function


Option Explicit
Option Base 1

Public connection AsObject
Public request AsString
Public recordset AsObject
Public matriceGlobale AsVariant
Public NBColonnes AsInteger
Public NBLignes AsInteger

SubClass_Initialize()
 Debug.Print"Object initialisé"
Set connection = CreateObject("ADODB.connection")
Set recordset = CreateObject("ADODB.Recordset")
End Sub

SubConnectionDB(Path AsString)
 connection.Provider = "Microsoft.ACE.OLEDB.16.0"
 connection.ConnectionString = "Data Source=" & Path & ";" & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
 connection.Open
 Debug.Print"Connection à la base dont le chemin d'accès est : " & Path
End Sub

SubDesignRequest(TexteDuSelect AsString, NomFeuille AsString)
 request = "SELECT " & TexteDuSelect & " FROM [" & NomFeuille & "$]"
 Debug.Print ("La request SQL est : " & request)
End Sub

SubAddToRequest(texte AsString)
 request = request & texte
 Debug.Print ("Ajoute de : " & texte)
 Debug.Print ("La requte totale est : " & request)
End Sub

SubExecuteRequest()
 request = request & ";"
 recordset.Open request, connection
 Debug.Print"Requete realisée"
IfNot recordset.EOF Then
' Extraction des données du Recordset dans une matrice

 matriceGlobale = recordset.GetRows() ' Attention : les données sont transposées
 NBLignes = UBound(matriceGlobale, 1)
 NBColonnes = UBound(matriceGlobale, 2)
End If
End Sub

SubPrintOutput(Position AsString)
 OutPut.Cells.Clear
 OutPut.Range(Position).CopyFromRecordset OutputClass
End Sub

SubMettreDansMatrice(matrice AsVariant)
 matrice = matriceGlobale
End Sub

SubCloseDB()
 connection.Close
End Sub