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
| Option Explicit
Dim Ar() As String
Private Function ExtraireValeur(sDossier As String, _
sFichier As String, _
sFeuille As String, _
sCellule As String)
Dim sArgument As String
sDossier = Replace(sDossier, "'", "''")
sFichier = Replace(sFichier, "'", "''")
sArgument = "'" & sDossier & "[" & sFichier & "]" & sFeuille & "'!" & Range(sCellule).Address(, , xlR1C1)
ExtraireValeur = ExecuteExcel4Macro(sArgument)
End Function
Sub Tst()
Dim Dossier As String
Dim Fichier As String
Dim Feuille As String
Dim Cellule As String
Dim sFichier As String
Dossier = "C:\Transfert\Test\"
Fichier = "Test.xls"
sFichier = Dossier & Fichier
ListeNomFeuilles sFichier
' Ar() contient le nom des feuilles dans l'ordre ALPHABETIQUE
' et non dans l'ordre des positions du classeur testé
Feuille = Ar(3)
Cellule = "A1"
ActiveSheet.Cells(1, 1) = ExtraireValeur(Dossier, Fichier, Feuille, Cellule)
End Sub
Private Sub ListeNomFeuilles(sNom As String)
Dim Conn As Object
Dim Cat As Object
Dim FeuilleXL As Object
Dim i As Long
Erase Ar
Set Conn = CreateObject("ADODB.Connection")
Set Cat = CreateObject("ADOX.Catalog")
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & sNom & ";Extended Properties=Excel 8.0;"
Set Cat.ActiveConnection = Conn
For Each FeuilleXL In Cat.Tables
Select Case Right$(FeuilleXL.Name, 1)
Case "$"
i = i + 1
ReDim Preserve Ar(i)
Ar(i) = Left$(FeuilleXL.Name, Len(FeuilleXL.Name) - 1)
Case "'"
' Nom de feuille comportant des espaces
i = i + 1
ReDim Preserve Ar(i)
Ar(i) = Mid$(FeuilleXL.Name, 2, Len(FeuilleXL.Name) - 3)
End Select
Next FeuilleXL
Conn.Close
Set Conn = Nothing
Set Cat = Nothing
End Sub |
Partager