Merci Chris !
Je suis en train de faire des tests mais je ne trouve pas PowerQuery J'ai Power Pivot c'est peut-être la même chose ? (j'avais évoqué powerQuery dans mon premier message car des amis m'en avait parlé).
Dans le code je vois un lien avec du DBF. Je pensais qu'Excel ne prenait plus en charge ce format de base de données (alors que j'en ai besoin...).
Peut-on exporter un fichier Excel directement en DBF ? Aujourd'hui je passe par Access
Public Rcd() As Variant
Sub Ouvrir_dbf()
Dim Rep As String, Tbl As String, T As Variant
Dim result As Long, i As Integer
Rep = Rep_A_Lire
If Not Rep = "" Then
T = List_dbf(Rep)
For i = 0 To UBound(T)
Tbl = Replace(UCase(T(i)), ".DBF", "")
If Not Tbl = "" Then
Sheets.Add
ActiveSheet.Name = Tbl
result = Query(Rep, "SELECT * FROM " & Tbl)
If Not UBound(Rcd, 2) = 0 Then
ActiveSheet.Range("A1").Resize(UBound(Rcd, 1), UBound(Rcd, 2)) = Rcd
End If
End If
Next i
End If
End Sub
Function Rep_A_Lire() As String
ChDrive Left(ActiveWorkbook.Path, 1)
ChDir ActiveWorkbook.Path
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "SELECTION DOSSIER DBF"
.Show
If .SelectedItems.Count > 0 Then Rep_A_Lire = .SelectedItems(1)
End With
End Function
Function List_dbf(Rep As String) As String()
Dim i As Integer, Fichier As String, T() As String
i = 0
Fichier = Dir(Rep & "\*.dbf")
Do While Fichier <> ""
i = i + 1
ReDim Preserve T(i)
T(i - 1) = Fichier
Fichier = Dir
Loop
If i > 0 Then List_dbf = T Else ReDim List_dbf(0)
End Function
Function Query(Rep As String, Req As String) As Long
Dim NDF As String, Cnx As Object, Rst As Object
Dim T As Variant, i As Long, j As Long, col As Integer
On Error Resume Next
Set Cnx = CreateObject("ADODB.Connection")
Cnx.Provider = "MSDASQL"
Cnx.Open "Driver={Microsoft dBASE Driver (*.dbf)};DriverID=277;Dbq=" & Rep & ";"
Set Rst = CreateObject("ADODB.Recordset")
Rst.Open Req, Cnx, 3
Query = Rst.RecordCount
col = Rst.Fields.Count
ReDim Rcd(Query + 1, col)
For j = 0 To col
Rcd(0, j) = Rst.Fields(j).Name
Next j
If Not Query = 0 Then
Rst.MoveFirst
T = Rst.GetRows
For i = 0 To Query
For j = 0 To col
Rcd(i + 1, j) = IIf(IsNull(T(j, i)), "", T(j, i))
Next j
Next i
End If
Cnx.Close
Set Rst = Nothing
Set Cnx = Nothing
End Function