Discussion :

[kprime59]

Salut à tous,

Je suis stagiaire pour une société. Je suis pas très doué en VBA.

On m'a demandé de créer une macro permettant de copier une certaine colonne d'une page ( fichier que je souhaiterai choisir à l'aide de ma macro ) vers un autre fichier. *

Je souhaiterai copier la colonne I du fichier choisi sur la dernière colonne non vide de l'autre fichier ( qui sera ouvert au préalable donc un .activate suffira )

Je ne sais pas si j'ai été clair. Peut-être que le code que j'ai écris parlera pour moi.

Voilà ce que j'ai déjà fait, cependant j'ai une erreur lors de l'activation du fichier choisit, je ne comprends pas pourquoi...

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
Sub AjoutEcoute()
 
Dim derlig As Long
derlig = Range("A" & Rows.Count).End(xlUp).Row
Dim dercol As Long
dercol = Cells(5, Cells.Columns.Count).End(xlToLeft).Column
 
Dim wbSource, wbFichierUsager As Workbook
Dim strFileName As String
Dim intChoice As Integer
 
Set wbFichierUsager = ThisWorkbook
 
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
intChoice = Application.FileDialog(msoFileDialogOpen).Show
If intChoice <> 0 Then
strFileName = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
Workbooks.Open strFileName
Set wbSource = ActiveWorkbook
Else
MsgBox " La procédure est annulée car aucun fichier n’a été entré. "
Exit Sub
 
End If
 
Dim i As Integer
Dim k As Integer
 k = 0
 
 
For i = 6 To 69 Step 1  ' les valeurs seront fixe
 
    Workbooks(strFileName).Activate ' c'est ici que ca coince...
 
    Worksheets("Grille Evaluation").Range("I" & i).Value = k
 
    Workbooks("JUIN 2015-Compétences BC").Activate
 
    Cells(8, dercol) = k
 
Next i
End Sub

Je donne en PJ deux fichiers exemples
Pièce jointe 181409
Pièce jointe 181410


Merci.

V.B.

[Quentin77170]

Salut à toi,

La raison simple pour laquelle cela ne fonctionne pas est que tu n'as pas spécifié l'extension dans le nom du workbook :

Code :

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

Workbooks("JUIN 2015-Compétences BC").Activate

Doit devenir :

Code :

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

Workbooks("JUIN 2015-Compétences BC.xlsm").Activate

Cependant, ne t'embête surtout pas avec ce genre de manip qui ne fonctionnera plus dès que le nom des fichiers sera changé... Utilise les variables objet que tu as déjà spécifiées plus haut !

Code :

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

Set wbFichierUsager = ThisWorkbook

Donc soit tu utilises wbFichierUsager.Activate soit ThisWorkbook.Activate, les deux sont du coup identiques.

Pareil pour :

Code :

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

Set wbSource = ActiveWorkbook

Donc tu utilises wbSource et plus Workbooks(strFileName)

Tu peux également simplifier en assignant le Workbooks(strFileName) directement en l'ouvrant et pas en l'ouvrant puis en l'assignant via l'ActiveWorkbook:

Code :

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

1
2
3
4
5
'Workbooks.Open strFileName
'Set wbSource = ActiveWorkbook
 
'Devient :
Set wbSource = Workbooks.Open strFileName

Enfin, dernière remarque, fais attention à ce que les fichiers que tu transmets ne contiennent pas de données confidentielles !! Si c'est le cas, supprime-les dès maintenant

[Invité]

Bonjour,
Regarde ça:

Code Module standard :

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
Sub test()
Dim Cnx As ADODBRD, Rs, Sql As String, R As Range, Fichier
Fichier = Application.GetOpenFilename("Excel Files (*.XLS), *.XLS,Excel Files (*.XLSX), *.XLSX,Excel Files (*.XLSM), *.XLSM")
If Fichier = False Then MsgBox "Annulation", vbExclamation, "Annulation": Exit Sub
Set Cnx = New ADODBRD
Cnx.TYPEBASE = ExcelSensTire
Cnx.BASE = Fichier 
Sql = "Select * from [Grille Evaluation$I:I]"
Set Rs = Cnx.OpenRecordSet(Sql)
Set R = ThisWorkbook.Sheets("Grille Evaluation").Range("A6").CurrentRegion
ThisWorkbook.Sheets("Grille Evaluation").Range("A6").Offset(0, R.Columns.Count).EntireColumn.Insert
ThisWorkbook.Sheets("Grille Evaluation").Range("A1").Offset(0, R.Columns.Count).CopyFromRecordset Rs
ThisWorkbook.Sheets("Grille Evaluation").Range("A1").Offset(0, R.Columns.Count).EntireColumn.AutoFit
Set Rs = Cnx.CloseRecordSet(Rs)
Cnx.CloseConnection
Set R = Nothing
Set Cnx = Nothing
End Sub

Code Classe ADODBRD :

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
Private Connexion
Public TYPEBASE As MyAdo
Public BASE
Public Server
Public Fichier
Public User
Public PassWord
Enum MyAdo
 ACCESS97 = 1
ACCESS2000 = 2
ACCESS2012 = 1
ODBC = 4
ORACLE = 5
 SQLSERVER2005 = 6
SQLServer2008R2 = 7
SQLite = 8
SQLite3 = 9
CSV = 10
ExcelSensTire = 11
ExcelAvecTire=12
End Enum
 
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 ExcelAvecTire
        GenereCSTRING = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & BASE & ";Extended Properties=""Excel 12.0;HDR=YES;"""
    Case ExcelSensTire
        GenereCSTRING = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & BASE & ";Extended Properties=""Excel 12.0;HDR=no;"""
    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 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 = "ODBC;DBQ=" & Fichier & ";Driver={Microsoft Text Driver (*.txt; *.csv)}; " & "DriverId=27;Extensions=txt,csv,tab,asc;FIL=text;MaxBufferS"
    Connex.Open
    Case Else
        GenereCSTRING = "PAS ASSEZ DE PARAMETRES RENSEIGNES !!!"
 
 
End Select
''MsgBox GenereCSTRING
'Response.End
End Function
 
 
Public Function OpenConnetion()
'Ouvre une connexion à  la base de données.
'Dim Fso As New Scripting.FileSystemObject
    OpenConnetion = False
    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
    Else
'  MsgBox Err.Description
 
    End If
'    Debug.Print Err.Description
    Err.Clear
    On Error GoTo 0
End Function
 
 
Public Function CloseConnection()
'Referme la connexion
CloseConnection = False
On Error Resume Next
    Connexion.Close
    Set Connexion = Nothing
     If Err = 0 Then
        CloseConnection = True
    End If
    Err.Clear
    On Error GoTo 0
End Function
 
 
Public Function OpenRecordSet(Sql)
'Retourne un RecordeSet
On Error Resume Next
    Dim Rs
Dim NbErr
 
Err.Clear
If Connexion.State = 0 Then
    OpenConnetion
End If
'Debug.Print Sql 'Replace(Sql, "%", "*")
    Set OpenRecordSet = CreateObject("ADODB.Recordset")
 
   ' OpenRecordSet.LockType = adLockOptimistic
    ''MsgBox  adLockOptimistic & vbcrlf & Err.Description
    OpenRecordSet.Open Sql, Connexion, 1, 3
 
    If Err Then
'   MsgBox Err.Description
 
    NbErr = NbErr + 1
        If NbErr < 11 Then
 
            Set OpenRecordSet = Nothing
 
 
        End If
 
    End If
    Err.Clear
 
End Function
Public Function RetournConnection()
Set RetournConnection = Connexion
End Function
Public Function OpenRecordSetParametre(Sql, Param)
Dim Commande
Dim Params
Set Commande = CreateObject("ADODB.Command")
Dim MyParameter
Set MyParameter = CreateObject("ADODB.Parameter")
Set Commande.ActiveConnection = Connexion
Commande.CommandText = "select Requête2.* from Requête2;"
 Commande.CommandType = adCmdText
 
 Set MyParameter = Commande.CreateParameter("[NumJob]", adNumeric)
         MyParameter.Value = 10
Commande.Parameters.Append MyParameter
 
 
 
'aa.Parameters.Append("MyRef") = "243410M660"
Set Rs2 = Commande.Execute
 
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
'         Err.Clear
'    NbErr = NbErr + 1
'    If NbErr < 11 Then
'
'        GoTo Reprise
'    End If
Else
    'MsgBox Err.Description
    End If
 
    Err.Clear
 
End Function

[kprime59]

Désolé du double post. Un grand merci à rdurupt ça marche à merveille.

Seul bémol, j'aurais aimé que la colonne AC5 (en fait la cinquième ligne de la dernière colonne non vide) porte le nom du fichier ouvert. Est-ce possible ?

De plus les notes sont attribués en texte et non en nombre. Comment modifier ?



Un grand merci. Je n'aurais jamais pu trouvé tout seul.

[Invité]

Bonjour,

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
Sub test()
Dim Cnx As ADODBRD, Rs, Sql As String, R As Range, Fichier, AC5
Fichier = Application.GetOpenFilename("Excel Files (*.XLS), *.XLS,Excel Files (*.XLSX), *.XLSX,Excel Files (*.XLSM), *.XLSM")
 
If Fichier = False Then MsgBox "Annulation", vbExclamation, "Annulation": Exit Sub
 AC5 = Split(Fichier, "\"): AC5 = Split(AC5(UBound(AC5)), ".")(0)
Set Cnx = New ADODBRD
Cnx.TYPEBASE = ExcelSensTire
Cnx.BASE = Fichier
Sql = "Select * from [Grille Evaluation$I:I]"
Set Rs = Cnx.OpenRecordSet(Sql)
Set R = ThisWorkbook.Sheets("Grille Evaluation").Range("A6").CurrentRegion
ThisWorkbook.Sheets("Grille Evaluation").Range("A6").Offset(0, R.Columns.Count).EntireColumn.Insert
ThisWorkbook.Sheets("Grille Evaluation").Range("A1").Offset(0, R.Columns.Count).CopyFromRecordset Rs
ThisWorkbook.Sheets("Grille Evaluation").Range("A5").Offset(0, R.Columns.Count) = AC5
ThisWorkbook.Sheets("Grille Evaluation").Range("A1").Offset(0, R.Columns.Count).EntireColumn.AutoFit
Set Rs = Cnx.CloseRecordSet(Rs)
Cnx.CloseConnection
Set R = Nothing
Set Cnx = Nothing
End Sub

[kprime59]

Bonjour,

Merci énormément pour cette macro. Même si je ne comprends pas tout malheuresement.

J'ai une erreur que je ne comprends pas lors de l'ajout de certains fichiers.

"Erreur d'exécution ' 2147217887 (80040e21)':

Vous ne pouvez pas enregistrer vos modifications, car une valeur que vous avez entrée viole les paramètres définis pour cette table ou cette liste (par exemple, une valeur est inférieure ou supérieure à la valeur maximale). Corrigez cette erreur et réessayez."

Il bloque sur cette ligne de code :

Code :

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

ThisWorkbook.Sheets("Grille Evaluation").Range("A1").Offset(0, R.Columns.Count).CopyFromRecordset Rs

[Invité]

un fichier XLSX dispose de 1048576 ligne! hors un fichier XLS n'en dispose que 65536!

si ton traitement consiste à prendre le contenu d'une colonne XLSM et de la placer dans un XLS ou réciproquement il y à incompatibilité!
nous allons limiter la taille!

Code :

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

Sql = "Select * from [Grille Evaluation$I1:I65536]"

[kprime59]

Je vais être lourd mais j'ai encore l'erreur... Avec 65536 lignes et même 1048576.

[Invité]

ça va sens dire mais ça va mieux en le disant, j'ai fait des testes!

il y à qq chose de particule dans ce fichier si tu devais mettre un %age de réussite?

li faut trouver ce qui les différenciés!

[kprime59]

Après avoir changé pour 1048576 lignes j'ai une nouvelle erreur

Erreur d'execution '5'
Argument ou appel de procédure incorrect

Et il coince toujours sur la même ligne. Les fichiers sont vraiment pareil.