Option Explicit
' ***********************************************************************
' ***** *****
' ***** CODE PierreP56 : http://tatiak.canalblog.com/ *****
' ***** *****
' ***********************************************************************
Public Cnx As Object, Rst As Object
Sub Connect_xls(Ndf As String)
Set Cnx = CreateObject("ADODB.Connection")
Cnx.provider = "MSDASQL"
Cnx.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & _
"DBQ=" & Ndf & "; ReadOnly=False;"
Set Rst = CreateObject("ADODB.Recordset")
End Sub
Function Select_Db(Req As String, Optional NoHead As Integer = 1) As Variant
Dim T As Variant, Rcd As Variant, f As Integer
Dim lig As Long, Col As Long, i As Long, j As Long
On Error GoTo errhdlr
ReDim Rcd(1 To 1, 1 To 1)
Rst.Open Req, Cnx, 3
lig = Rst.RecordCount
If lig > 0 Then
Rst.MoveFirst
T = Rst.GetRows
Col = Rst.Fields.Count
ReDim Rcd(1 To lig + NoHead, 1 To Col)
For j = 0 To Col - 1
Rcd(1, j + 1) = Rst.Fields(j).Name
For i = 0 To lig - 1
Rcd(i + 1 + NoHead, j + 1) = IIf(IsNull(T(j, i)), Null, T(j, i))
Next i
Next j
End If
Select_Db = Rcd
Exit Function
errhdlr:
Rcd(1, 1) = "Erreur n°" & Err.Number & vbCrLf & Err.Description
Select_Db = Rcd
f = FreeFile()
Open ThisWorkbook.Path & "\Log.txt" For Append As #f
Print #f, Now() & " | " & Rcd(1, 1) & vbCrLf
Close #f
End Function
Sub Close_Cnx(Optional x As Byte)
On Error Resume Next
If x > 0 Then Rst.Close
If Cnx_IsOpen Then Cnx.Close
Set Cnx = Nothing
Set Rst = Nothing
End Sub
Function Cnx_IsOpen() As Boolean
On Error Resume Next
Cnx_IsOpen = (Cnx.State = 1)
End Function
' *************************************************************************************************
Sub Macro1()
Dim ch As String 'déclare la variable ch (CHemin d'accès)
Dim cc As Workbook 'déclare la variable cc (Classeur Cible)
Dim fs As Variant 'déclare la variable fs (FichierS)
Dim cs As Workbook 'déclare la variable cs (Claseur Source)
Dim os As Object 'déclare la variable os (Onglet Source)
Dim li As Long 'déclare la variable li (LIgne)
Dim Requete As String
Dim T As Variant
ch = "\\XXX\DEMANDES\" 'définit le chemin d'acces ch (à vérifier dans ton cas)
Set cc = ThisWorkbook 'définit le classeur cible cc
fs = Dir(ch & "*.xlsx") 'définit les fichiers du dossier de ch
Do Until fs = "" 'boucle tant que fs n'est pas vide
li = IIf(cc.Sheets("SYNTHESE").Range("A2").Value = "", 2, cc.Sheets("SYNTHESE").Cells(Application.Rows.Count, 1).End(xlUp).Row + 1) 'définit la première ligne vide de la colonne A du classeur cible
Connect_xls "ch & fs"
T = Select_Db("SELECT * FROM [DDS$A1:D80]")
cc.Sheets("SYNTHESE").Range("A" & li).Value = T(3, 3)
cc.Sheets("SYNTHESE").Range("B" & li).Value = T(4, 6)
cc.Sheets("SYNTHESE").Range("C" & li).Value = T(2, 1)
Close_Cnx
fs = Dir 'définit fs comme le prochain fichier du dossier de ch
Loop 'boucle
End Sub
