Sub TEST()
'Call ExtraireCopierCellules("Nom du chemin complet (Fichier compris)", "Onglet du fichier fermé", "Plage a récupérer", False, "Cellule a/c de laquelle seront copiées les données")
Call ExtraireCopierCellules("C:\MesDocuments\Paninak.xlsx", "Feuil1", "A1:F100", False, "H7")
End Sub
Sub ExtraireCopierCellules(ByVal xNomPathFile As String, ByVal xOnglet As String, ByVal xPlage As String, xEntete As Boolean, xCellule As String)
'----------------------------------------------------------------------
' POUR INFORMATION
'
' Nécessite la référence Microsoft ActiveX Data Objects x.x Library
'
' xNomPathFile = Nom du chemin et du fichier complet
' xOnglet = Nom de l'onglet du classeur fermé
' xPlage = Plage de cellule à lire (Doit dépasser la valeur de la dernière ligne et colonne pour pouvoir récupérer l'intégralité Ligne et Colonne)
' xEntete = Indiquer True / False si on veut ou pas récupérer les entêtes de données
' xCellule = Cellule (du fichier ouvert) à partir de laquelle les données seront copiées
'----------------------------------------------------------------------
Dim Cn As ADODB.Connection
Dim Rst As ADODB.Recordset
Dim ADOCommand As ADODB.Command
If OkSheetName(xNomPathFile, xOnglet) Then 'Vérifier que l'onglet existe dans le fichier source
'----------------------------------------------------------------
' Ouvrerture VIRTUELLE du Fichier
'----------------------------------------------------------------
Set Cn = New ADODB.Connection 'Connexion
With Cn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & xNomPathFile & ";Extended Properties=""Excel 12.0;HDR=YES;"""
.Open
End With
'----------------------------------------------------------------
' Requête
'----------------------------------------------------------------
Set ADOCommand = New ADODB.Command 'Requête pour lire la xPlage recherchée
With ADOCommand
.ActiveConnection = Cn
.CommandText = "SELECT * FROM [" & xOnglet & "$" & xPlage & "]"
End With
Set Rst = New ADODB.Recordset
Rst.Open ADOCommand, , adOpenKeyset, adLockOptimistic
xLig = Rst.RecordCount + 1 'Permet de connaitre la dernière ligne du fichier fermé
xCol = Rst.Fields.Count 'Permet de connaitre la dernière colonne du fichier fermé
xLettreColonne = Split(Cells(1, xCol).Address, "$")(1) 'Transforme la valeur de la colonne en lettre Excel
xPlage = Left(xPlage, 3) & xLettreColonne & xLig 'Redefini la Plage d'origine en nouvelle Plage
Set Rst = Cn.Execute("[" & xOnglet & "$" & xPlage & "]")
'----------------------------------------------------------------
' Détermine la ligne et la colonne ou seront copiées les données
'----------------------------------------------------------------
For F = 1 To Len(xCellule)
If IsNumeric(Mid(xCellule, F, 1)) = True Then
xPos = F
Exit For
End If
Next F
xLig2 = Val(Mid(xCellule, xPos, 10))
xCol2 = Range(Left(xCellule, xPos - 1) & 1).Column 'Transforme la lettre de la colonne en valeur chiffrée
'----------------------------------------------------------------
' Copie les données lues a/c de la cellule
'----------------------------------------------------------------
'---------------------------------------------------- RECUPERATION DES ENTESTES
If xEntete = True Then
For F = 1 To xCol
'Précision : Si l'entête est vierge, la macro inscrira F? (Field n°) à la place
Cells(xLig2, xCol2 - 1 + F) = Rst.Fields(F - 1).Name
Next F
xLig2 = xLig2 + 1
End If
'---------------------------------------------------- RECUPERATION DU RESTE DES DONNEES
Do While Not Rst.EOF 'Boucle sur les données
If Rst.Fields(0).Value <> "" Then
For F = 1 To xCol
Cells(xLig2, xCol2 - 1 + F) = Rst.Fields(F - 1).Value 'Passe en revue toutes les colonnes
Next F
xLig2 = xLig2 + 1
End If
Rst.MoveNext 'Prochaine ligne
Loop
'----------------------------------------------------------------
' Fermeture de la connection
'----------------------------------------------------------------
Rst.Close
Cn.Close
Set Cn = Nothing
Set Rst = Nothing
Set ADOCommand = Nothing
End If
End Sub
Private Function OkSheetName(FullPathFile As String, SheetName As String) As Boolean
'----------------------------------------------------------------------
' POUR INFORMATION
'
' Nécessite la référence Microsoft ADO Ext. 6.0 for DDL and Security
'----------------------------------------------------------------------
Dim Cn As ADODB.Connection
Dim oCat As ADOX.Catalog
Dim Tbl As Object
Set Cn = New ADODB.Connection
xOnglet = SheetName & "$"
With Cn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FullPathFile$ & ";Extended Properties=""Excel 12.0;HDR=YES;"""
.Open
End With
Set oCat = New ADOX.Catalog
Set oCat.ActiveConnection = Cn
For Each Tbl In oCat.Tables
If Tbl.Name Like xOnglet Then
OkSheetName = True
GoTo Suite
End If
Next Tbl
MsgBox "L'onglet " & SheetName & " ne se trouve pas dans le fichier " & FullPathFile, vbCritical, "PAS D'ONGLET DANS LE FICHIER SPECIFIE"
Suite:
Set oCat = Nothing: Cn.Close: Set Cn = Nothing
End Function