Consolider fichier via Ado et Fichier ouvert par un autre utilisateur

**Drisc007** · 15/09/2016, 10h00

Bonjour,
J'ai une macro qui permet de regrouper tout les fichiers Excel (*.xlsm) d'un dossier.
Cette macro fonctionne correctement quand aucun fichier n'est ouvert par un utilisateur.
Par contre si un utilisateur est entrain de modifier un fichier lors de l'exécution de la macro :
Je reçois le message suivant "Fichier en cours d'utilisation 20.xlsm est verrouillé pour modification par ..." et la macro ouvre le fichier en lecture seule et laisse ouvert en lecture seule tout les fichiers en cours d'utilisation.
J'aimerais ne pas avoir ce message et que les fichiers reste fermé.
Merci d'avance

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
Option Explicit
Sub Compiler(ByVal control As IRibbonControl)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Déclaration des variables
Dim Cn As ADODB.Connection
Dim Rst As ADODB.Recordset
Dim Fichier As String
Dim NomFeuille As String, texte_SQL As String, Dossier As String
Dim n As Integer, i As Integer
 
'Efface le précedent import
ThisWorkbook.Worksheets("data").Range("A2:AZ10000").ClearContents
 
n = 1 'numéro fichier
i = 2 'numéro de ligne dans la feuille data du fichier synthèse
 
'Boucle sur tout les fichiers contenu dans le répertoir Liste
For n = 1 To 10000
    'Test si le fichier n.xlsm existe sinon arrete le programmme
    If Dir(ThisWorkbook.Path & "\Liste\" & n & ".xlsm") = "" Then
        Exit For
    End If
    NomFeuille = "data"
    Fichier = ThisWorkbook.Path & "\Liste\" & n & ".xlsm"
 
     Set Cn = New ADODB.Connection
 
        '--- Connexion ---
        With Cn
            .Mode = adModeWrite
            .Provider = "Microsoft.Jet.OLEDB.4.0"
            .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
                & Fichier & ";Extended Properties=""Excel 12.0;HDR=YES;IMEX=1"""
            .Open
        End With
        '-----------------
 
        'La requête
        texte_SQL = "SELECT * FROM [" & NomFeuille & "$]"
 
        Set Rst = New ADODB.Recordset
        With Rst
            .CursorType = adOpenForwardOnly
        End With
        Set Rst = Cn.Execute(texte_SQL)
 
        'Ecrit le résultat de la requête
        ThisWorkbook.Worksheets("data").Cells(i, 1).CopyFromRecordset Rst
 
 
        '--- Fermeture connexion ---
        Cn.Close
        Set Cn = Nothing
 
    'Recherche le numéro de la dernière ligne et ajoute 1
    With ThisWorkbook.Worksheets("data")
    i = .Range("A" & Rows.Count).End(xlUp).Row + 1
    End With
Next
 
'Conversion des colonnes en date
Dim T() As Variant, L As Long, c As Long, Derlign As Long
 
Derlign = ThisWorkbook.Worksheets("data").Cells(Columns(1).Cells.Count, 1).End(xlUp).Row
With Worksheets("data").Range("C2:F" & Derlign).Cells
    T = .Value
    On Error Resume Next
    For L = 1 To UBound(T, 1): For c = 1 To UBound(T, 2)
       If Not IsEmpty(T(L, c)) Then T(L, c) = CDate(T(L, c))
       Next c, L
    On Error GoTo 0
    .NumberFormat = "dd/mm/yy"
    .Value2 = T: End With
 
With Worksheets("data").Range("M2:O" & Derlign).Cells
    T = .Value
    On Error Resume Next
    For L = 1 To UBound(T, 1): For c = 1 To UBound(T, 2)
       If Not IsEmpty(T(L, c)) Then T(L, c) = CDate(T(L, c))
       Next c, L
    On Error GoTo 0
    .NumberFormat = "dd/mm/yy"
    .Value2 = T: End With
 
'Conversion en numerique
With Worksheets("data").Range("B2:B" & Derlign).Cells
    T = .Value
    On Error Resume Next
    For L = 1 To UBound(T, 1): For c = 1 To UBound(T, 2)
       If Not IsEmpty(T(L, c)) Then T(L, c) = CDate(T(L, c))
       Next c, L
    On Error GoTo 0
    .NumberFormat = "0"
    .Value2 = T:
End With
 
With Worksheets("data").Range("H2:H" & Derlign).Cells
    T = .Value
    On Error Resume Next
    For L = 1 To UBound(T, 1): For c = 1 To UBound(T, 2)
       If Not IsEmpty(T(L, c)) Then T(L, c) = CDate(T(L, c))
       Next c, L
    On Error GoTo 0
    .NumberFormat = "0"
    .Value2 = T:
End With
 
With Worksheets("data").Range("K2:K" & Derlign).Cells
    T = .Value
    On Error Resume Next
    For L = 1 To UBound(T, 1): For c = 1 To UBound(T, 2)
       If Not IsEmpty(T(L, c)) Then T(L, c) = CDate(T(L, c))
       Next c, L
    On Error GoTo 0
    .NumberFormat = "0"
    .Value2 = T:
End With
 
With Worksheets("data").Range("V2:V" & Derlign).Cells
    T = .Value
    On Error Resume Next
    For L = 1 To UBound(T, 1): For c = 1 To UBound(T, 2)
       If Not IsEmpty(T(L, c)) Then T(L, c) = CDate(T(L, c))
       Next c, L
    On Error GoTo 0
    .NumberFormat = "0"
    .Value2 = T:
End With
 
With Worksheets("data").Range("Y2:Y" & Derlign).Cells
    T = .Value
    On Error Resume Next
    For L = 1 To UBound(T, 1): For c = 1 To UBound(T, 2)
       If Not IsEmpty(T(L, c)) Then T(L, c) = CDate(T(L, c))
       Next c, L
    On Error GoTo 0
    .NumberFormat = "0"
    .Value2 = T:
End With
 
With Worksheets("data").Range("AA2:AT" & Derlign).Cells
    T = .Value
    On Error Resume Next
    For L = 1 To UBound(T, 1): For c = 1 To UBound(T, 2)
       If Not IsEmpty(T(L, c)) Then T(L, c) = CDate(T(L, c))
       Next c, L
    On Error GoTo 0
    .NumberFormat = "0"
    .Value2 = T:
End With
 
With Worksheets("data").Range("AW2:AW" & Derlign).Cells
    T = .Value
    On Error Resume Next
    For L = 1 To UBound(T, 1): For c = 1 To UBound(T, 2)
       If Not IsEmpty(T(L, c)) Then T(L, c) = CDate(T(L, c))
       Next c, L
    On Error GoTo 0
    .NumberFormat = "0"
    .Value2 = T:
End With
 
'----
 
'Mise à jour de tout les TCD
ThisWorkbook.RefreshAll
 
ThisWorkbook.Worksheets("Liste").Range("S1").Value = Now
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Invité · 15/09/2016, 12h08

Pour information la connexion et la déconecxion AdoDb est relativement lente et tu gagnerais du temps en faisant une connexion type CSV ou thisworkbok et en faisant une jonction externe dans ta requête!

Code :

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

& Fichier & ";Extended Properties=""Excel 12.0;HDR=YES;IMEX=1;Mode=Read;"""

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
Option Explicit
Sub Compil()
With CreateObject("adodb.connection")
            .Provider = "Microsoft.Jet.OLEDB.4.0"
            .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
                & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=YES;IMEX=1"""
            .Open
            For n = 1 To 10000
    'Test si le fichier n.xlsm existe sinon arrete le programmme
    If Dir(ThisWorkbook.Path & "\Liste\" & n & ".xlsm") = "" Then
        Exit For
    End If
    NomFeuille = "data"
    Fichier = ThisWorkbook.Path & "\Liste\" & n & ".xlsm"
         'La requête
         texte_SQL = "SELECT * FROM [" & NomFeuille & "$] in '" & ThisWorkbook.Path & "\Liste\" & n & ".xlsm" & "' 'Excel 12.0;HDR=YES;IMEX=1;Mode=Read;'"""
          Set Rst = Cn.Execute(texte_SQL)
         'Ecrit le résultat de la requête
        ThisWorkbook.Worksheets("data").Cells(i, 1).CopyFromRecordset Rst
        Rst.Close: Set Rst = Nothing
    'Recherche le numéro de la dernière ligne et ajoute 1
    With ThisWorkbook.Worksheets("data")
    i = .Range("A" & Rows.Count).End(xlUp).Row + 1
    End With
Next
            .Close
End With
 End Sub

**Drisc007** · 16/09/2016, 10h05

Le code ouvre bien en lecture seule mais j'ai toujours la notification qui suspend la macro (j'ai la notification uniquement sur le réseau de mon entreprise pas sur mon réseau personnel pourtant j'avais bien des fichiers ouvert par d'autres utilisateur.
Est ce qu'il y a un parametre notify:= False pour une connexion adodb
exemple : Workbooks.Open RepertoireFichier, notify:=False (pour ouvrir un fichier sans notification)

Merci d'avance

Invité · 16/09/2016, 10h23

Bonjour,
il faut que tu te connectes sur ThisWorkbook.FullName et que tu faces un lien extern comme dans mon dernière exemple!

Code :

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

1
2
3
4
On Error Resume Next
Set Rst = Cn.Execute(texte_SQL)
On Error GoTo 0
If TypeName(Rst) = "Nothing" Then MsgBox "Err"

Consolider fichier via Ado et Fichier ouvert par un autre utilisateur

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager