[XL-2010] Jointure type SQL en VBA

Jointure type SQL en VBA

Bonjour à tous :)!
Je dispose d'un fichier constitué de 9 colonnes et 4636 lignes. Chacune des colonnes constitue les attributs d'une table. Parmi ces colonnes, 2 sont des codes barres (uniques) qui sont exactement les mêmes a un décalage de ligne prés. Ex : Cellule A3 Code_Barre1 , Cellule B6 Code_Barre1.
Voici le schéma de ma table : Table(Code_barre1,Code_barre2,Attribut3,...,Attribut6)
Mon objectif est de réorganiser les lignes de telle sorte que Code_barre1 = Code_Barre2 avec bien évidement les bonnes informations des attributs 1 à 6 correspondant a code_barre2.
Je suis débutant en VBA et j'ai tenté de faire un code qui tourne mais qui ne fait absolument rien ! :calim2:
Voici le code en question :
Code:

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 Sub Jointure() Dim i As Integer Dim L As Variant Dim S As Variant Dim a As Integer Dim b As Integer Dim c As Integer Dim d As Integer Dim Ligne As Integer a = Sheets("Mouvement MAR").Cells(11, 11).Value b = Sheets("Mouvement MAR").Cells(10, 11).Value c = Sheets("Mouvement MAR").Cells(10, 10).Value d = Sheets("Mouvement MAR").Cells(11, 10).Value For Ligne = b + 1 To a + b - 1 For i = c + 1 To c + d If Sheets("Mouvement MAR").Cells(Ligne, 1).Value = Sheets("Mouvement MAR").Cells(i, 2).Value Then L = Sheets("Mouvement MAR").Range("B" & CStr(i) & ":" & "G" & CStr(i)).Value S = Sheets("Mouvement MAR").Range("B" & CStr(Ligne) & ":" & "G" & CStr(Ligne)).Value Sheets("Mouvement MAR").Range("B" + CStr(i) & ":" & "G" + CStr(i)).Value = L Sheets("Mouvement MAR").Range("B" + CStr(Ligne) & ":" & "G" + CStr(Ligne)).Value = S End If Next Next End Sub
Merci par avance pour votre aide. :) :) :)

Bonjour,

Pour l'occasion,c'est pas la position des cellules qui importe mais les entête de colonnes.

[A1]=Champ

Deplus explique ce que tu veux faire, je ne vais pas analyser ton code.

Tout d'abord merci pour ta réponse.
Je dispose dans une feuille de 9 colonnes dont 2 correspondent a des codes barres. Ces 9 colonnes sont issues d'un copier collé et il arrive régulièrement que la colonne 1 soit décalée par rapport aux colonnes 2 à 9 ou bien qu'il y ait plus de ligne dans la colonne 1 que dans celle de 2 à 9 et vice versa.
Mon objectif est de tout remettre en ordre c'est à dire que lorsque le code barre dans la colonne 1 est égale au code barre de la colonne 2 je place le contenu des colonnes 2 à 9 a droite de la ligne de la colonne 1 contenant le code barre égal.

Ce que je fais dans le code c'est que je dis que si le code barre est égale je permute le range de la ligne contenant le code_barre2 à la ligne contenant le code_barre1 en première colonne.

Si tu disposais d'un fichier d'exemples de quelques lignes ?

1 pièce(s) jointe(s)

Voici un exemple. Je ne peux pas t'envoyer le fichier entier car c'est pour le boulot et c'est confidentiel. Mais dans l'idée tu pourras comprendre ce que je veux faire dans cet exemple. :D

Citation:

Envoyé par mikoux13

Ce que je fais dans le code c'est que je dis que si le code barre est égale je permute le range de la ligne contenant le code_barre2 à la ligne contenant le code_barre1 en première colonne.

Par exemple:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Sub Reorganisation()
Dim LastLig As Long, i As Long
Dim Cb As String
Dim c As Range
 
Application.ScreenUpdating = False
With Worksheets("Mouvement MAR")
    LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
    For i = 2 To LastLig
        Cb = .Range("A" & i)
        If .Range("B" & i) <> Cb Then
            Set c = .Range("B1:B" & LastLig).Find(Cb, LookIn:=xlValues, lookat:=xlWhole)
            If Not c Is Nothing Then
                c.Resize(, 7).Copy .Range("B" & LastLig + 1)
                .Range("B" & i).Resize(, 7).Copy c
                .Range("B" & LastLig + 1).Resize(, 7).Cut .Range("B" & i)
                Set c = Nothing
            Else
                .Range("A" & i).Cut .Range("A" & LastLig + 1)
            End If
        End If
    Next i
End With
End Sub

Merci beaucoup cela fonctionne ;) mais ça prend beaucoup beaucoup de temps. Il y a t-il un moyen d’accélérer le processus ? :P

1 pièce(s) jointe(s)

à tester!

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub test()
With Sheets("Feuil3")
    .Range(.Cells(2, "A"), .Cells(.Cells.Rows.Count, "G").End(xlUp)).Clear
End With
Dim cn As New ADODBRD
cn.TYPEBASE = xls: cn.AvecTitre = True: cn.Base = ThisWorkbook.FullName
cn.OpenConnetion
Sql = "select frm1.* from [Mouvement MAR$] as frm1 inner join  [Mouvement MAR$] as frm2 on frm2.F1=frm1.F1 "
Sql = Sql & " union all"
Sql = Sql & " select frm1.* from [Mouvement MAR$] as frm1 left join  [Mouvement MAR$] as frm2 on frm2.F1=frm1.F1 where frm2.F1 is null"
Sql = Sql & " order by frm1.F1"
Set Rs = cn.OpenRecordset(Sql)
Sheets("Feuil3").Range("A2").CopyFromRecordset Rs
Set Rs = cn.CloseRecordSet(Rs)
cn.CloseConnection
Sheets("Feuil3").Select
End Sub

Code:

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
Private Connexion
Public TYPEBASE As MyAdo
Public Base
Public Server
Public fichier
Public User
Public PassWord
Public Enum ConstopenChema
    adSchemaColumns = 4 '   This value indicates that the QueryType is requesting column information for tables on the server (not supported when connecting to mainframes).
    adSchemaIndexes = 12 '  This value indicates that the QueryType is requesting index information about the tables on the server (not supported when connecting to mainframes).
    adSchemaTables = 20 ' This value indicates that the QueryType is requesting information about the tables on the server.
    adSchemaProviderTypes = 22 '  This value indicates that the QueryType is requesting provider-type information.
End Enum
Public Enum MyAdo
    ACCESS97 = 1
    ACCESS2000 = 2
    ACCESS2012 = 3
    ODBC = 4
    ORACLE = 5
    SQLSERVER2005 = 6
    SQLServer2008R2 = 7
    SQLite = 8
    SQLite3 = 9
    CSV = 10
    xls = 11
    MySQL = 12
End Enum
Public Enum CommAdo
    adCmdFile = 256
    adCmdStoredProc = 4
    adCmdTable = 2
    adCmdTableDirect = 521
    adCmdText = 1
    adCmdU
    nknown = 8
End Enum
Public AvecTitre As Boolean
Public Enum AdodbTypeChamps
   adEmpty = 0
    adSmallInt = 2
    adInteger = 3
    adSingle = 4
    adDouble = 5
    adCurrency = 6
    adDate = 7
    adBSTR = 8
    adIDispatch = 9
    adError = 10
    adBoolean = 11
    adVariant = 12
    adIUnknown = 13
    adDecimal = 14
    adTinyInt = 16
    adUnsignedTinyInt = 17
    adUnsignedSmallInt = 18
    adUnsignedInt = 19
    adBigInt = 20
    adUnsignedBigInt = 21
    adFileTime = 64
    adGUID = 72
    adBinary = 128
    adChar = 129
    adWChar = 130
    adNumeric = 131
    adUserDefined = 132
    adDBDate = 133
    adDBTime = 134
    adDBTimeStamp = 135
    adChapter = 136
    adPropVariant = 138
    adVarNumeric = 139
    adVarChar = 200
    adLongVarChar = 201
    adVarWChar = 202
    adLongVarWChar = 203
    adVarBinary = 204
    adLongVarBinary = 205
End Enum
Public Enum ParameterDirection
    adParamUnknown = 0
    adParamInput = 1
    adParamOutput = 2
    adParamInputOutput = 3
    adParamReturnValue = 4
End Enum
Public Sub ShemaIn(fichier As String, Delimited As String)
Dim txt As String
txt = "[" & fichier & "]" & vbCrLf & "Format= " & Delimited
Dim fso, NewFichier
Set fso = CreateObject("Scripting.FileSystemObject")
Set NewFichier = fso.OpenTextFile(Server & "\schema.ini", 2, True)
NewFichier.Write txt
NewFichier.Close
Set NewFichier = Nothing
Set fso = Nothing
End Sub
Public Property Get Connection()
Set Connection = Connexion
End Property
 
 
 
 
Public Property Get PremiereTableAdo() As String
With Connexion.OpenSchema(20)
    If Not .EOF Then
        PremiereTableAdo = .Fields("TABLE_NAME")
    End If
    .Close
End With
End Property
Public Property Get TableExiste(TableName As String) As Boolean
With Connexion.OpenSchema(20)
    If Not .EOF Then
      .Filter = "TABLE_NAME ='" & TableName & "'"
       TableExiste = Not .EOF
    End If
    .Close
End With
End Property
Public Property Get TableToutes()
TableToutes = False
With Connexion.OpenSchema(20)
    If Not .EOF Then
      TableToutes = .getrows
 
 
    End If
    .Close
End With
End Property
 
Public Function Param(Champs As String, AdType As AdodbTypeChamps, Direction As ParameterDirection, size As Integer, Value As Variant) As Object
Set Param = CreateObject("ADODB.Command").CreateParameter(Champs, AdType, Direction, size, Value)
End Function
 
 
Public Function CommadExecute(adCm As CommAdo, Parameters As Variant, Sql As String) As Object
Dim I As Integer
  With CreateObject("ADODB.Command")
    .ActiveConnection = Connexion
    .CommandType = adCm
    .CommandTimeout = 500
    For I = 0 To UBound(Parameters)
        .Parameters.Append Parameters(I)
    Next
    .CommandText = Sql
    Set CommadExecute = .Execute
  End With
End Function
 
 
Private Function GenereCSTRING()
'Permet de générer le Cornec String
'1 - ACCESS 97
'2 - ACCESS 2000
'3 - ACCESS 2012
'4 - ODBC
'5 - ORACLE
'6 - SQL SERVER 2005
'7 - SQL Server 2008 R2
'8 - SQLite
'9 - SQLite3
If Trim("" & fichier) = "" Then fichier = Base
Select Case TYPEBASE
    Case xls
            GenereCSTRING = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Base & ";Extended Properties=""Excel 12.0;HDR=" & Array("No", "YES")(Abs(AvecTitre)) & ";"""
    Case ACCESS97
        GenereCSTRING = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=" & fichier
    Case ACCESS2000
        GenereCSTRING = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & fichier & ";Persist Security Info=False"
    Case ACCESS2012
        GenereCSTRING = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & fichier & ";"
    Case MySQL
    GenereCSTRING = " DRIVER={MySQL ODBC 5.1 Driver};SERVER=" & Server & ";UID=" & User & ";DATABASE=" & Base & ";Password=" & PassWord
    Case ODBC
        GenereCSTRING = "Provider=MSDASQL.1;Password=" & PassWord & ";Persist Security Info=True;User ID=" & User & ";Data Source=" & Base
    Case ORACLE
        GenereCSTRING = "Provider=OraOLEDB.Oracle.1;Password=" & PassWord & ";Persist Security Info=True;User ID=" & User & ";Data Source=" & Base
    Case SQLSERVER2005
        GenereCSTRING = "Provider=SQLOLEDB.1;Password=" & PassWord & ";Persist Security Info=True;User ID=" & User & ";Initial Catalog=" & Base & ";Data Source=" & Server
    Case SQLServer2008R2
        GenereCSTRING = "Provider=SQLNCLI;Server=" & Server & ";Database=" & Base & ";UID=" & User & ";PWD=" & PassWord & ";"
    Case SQLite
        GenereCSTRING = "Provider=OleSQLite.SQLiteSource.3; Data Source=" & fichier
        GenereCSTRING = "Driver={SQLite ODBC (UTF-8) Driver};Database=" & fichier & ";StepAPI=;Timeout="
    Case SQLite3
        GenereCSTRING = "Driver={SQLite3 ODBC Driver};Database=" & fichier & ";LongNames=0;Timeout=4000;NoTXN=0;SyncPragma=NORMAL;StepAPI=0;"
    Case CSV
        GenereCSTRING = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Server & ";Extended Properties=""Text;HDR=" & Array("No", "YES")(Abs(AvecTitre)) & ";FMT=Delimited;"""
    Case Else
        GenereCSTRING = "PAS ASSEZ DE PARAMETRES RENSEIGNES !!!"
End Select
End Function
 
Public Function OpenSchema(Shama As ConstopenChema)
If Connexion.State = False Then
    OpenConnetion
End If
Set OpenSchema = Connexion.OpenSchema(Shama)
End Function
Public Function OpenConnetion()
    OpenConnetion = False 'Ouvre une connexion à  la base de données.
    On Error Resume Next
    Dim ConnecString
     Dim NbErr
    Set Connexion = CreateObject("ADODB.Connection")
    Connexion.Open GenereCSTRING 'ConnecString
    If Err = 0 Then
        OpenConnetion = True
       Connexion.CommandTimeout = 14400
    End If
    Debug.Print Err.Description
    Err.Clear
    On Error GoTo 0
End Function
Public Function CloseConnection()
CloseConnection = False
On Error Resume Next
    Connexion.Close 'Referme la connexion
    Set Connexion = Nothing
     If Err = 0 Then
        CloseConnection = True
    End If
    Err.Clear
    On Error GoTo 0
End Function
Public Function OpenRecordset(Sql) As Object
'Retourne un RecordeSet
On Error Resume Next
    Dim Rs
Dim NbErr
Err.Clear
If Connexion.State = 0 Then
    OpenConnetion
End If
    Set OpenRecordset = CreateObject("ADODB.Recordset")
    OpenRecordset.Open Sql, Connexion, 1, 3
    If Err Then
    MsgBox Err.Description
       Set OpenRecordset = Nothing
    End If
    Err.Clear
End Function
Public Function RetournConnection()
Set RetournConnection = Connexion
End Function
Public Function CloseRecordSet(Rs)
On Error Resume Next
    Rs.Close
    Set CloseRecordSet = Nothing
End Function
Public Function Execute(Sql)
    Execute = False
    On Error Resume Next
    Dim NbErr
Reprise:
If Connexion.State = 0 Then
    OpenConnetion
End If
Debug.Print Sql
    Connexion.Execute Sql
    If Err = 0 Then
        Execute = True
Else
    MsgBox Err.Description
    End If
Err.Clear
End Function

Merci beaucoup à tous ! Tout fonctionne avec un temps plutôt raisonnable.
Bonne journée , bonnes vacances et à bientôt ! :mouarf::mouarf::mouarf::mouarf::mouarf::mouarf::lol::lol::lol::lol::lol::lol::lol::lol: