Microsoft 365 importer une plage d'un fichier fermé

Option Explicit
Sub LitClasseurFermé()
    Dim Rsource As Range, Rdest As Range, chemin$, fichier$, Onglet$, nblignes&, T#, X

    chemin = ThisWorkbook.Path    'chemin du fichier source
    fichier = "JournalAux-97.xlsx"    'nom du fichier source
    Onglet = "JournalReport"    'feuille du fichier source
    T = Timer
    
    'on va chercher le nombre de ligne utiliser dans la feuille"journalreport" du  fichier fermé
    nblignes = GetLastRowInClosedFich(chemin & "\" & fichier, "A1:K500000", Onglet)


    Set Rsource = [A1:k1].Resize(nblignes)   ' plage du fichier source
    Set Rdest = ShDatas.[A1].Resize(Rsource.Rows.Count, Rsource.Columns.Count)    'destination
    X = LitChamp(Rdest, chemin, fichier, Onglet, Rsource)    'lance l'execution
    MsgBox Format(Timer - T, "#0.000 /sec") & vbCrLf & "pour " & nblignes & " lignes   et " & [K1].Column & " colonnes copiées "

End Sub

Function LitChamp(Rdest As Range, chemin, fichier, Onglet, Rsource As Range)
    Application.ScreenUpdating = False
    Rdest.FormulaArray = "=""""&'" & chemin & "\[" & fichier & "]" & Onglet & "'!" & CStr(Rsource.Address(0, 0))    'formule matricielle de liaison
    Rdest = Rdest.Value    'supression des formulesremplacement des formules par les valeurs
    Application.ScreenUpdating = True
End Function

'function pour connaitre  le nombre de lignes utilisées dans le fichier fermé
'patricktoulon sur Exceldownloads
'version 2.0
'date version : 26/02/2023
Function GetLastRowInClosedFich(fichier As String, Rng As String, Optional Feuille As String = "", Optional headerTable As Boolean = False)
    Dim HDR As String, RsTLigne As Integer, RsTCol As Integer
    Dim AdConn As Object, AdoComand As Object, rst As Object
    Set AdConn = CreateObject("ADODB.Connection"): Set AdoComand = CreateObject("ADODB.Command"): Set rst = CreateObject("ADODB.Recordset")
    AdConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & fichier & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1;"""
    AdoComand.ActiveConnection = AdConn
    If Feuille = "" _
       Then AdoComand.CommandText = "SELECT * from `" & Rng & "`" _
       Else AdoComand.CommandText = "SELECT * from `" & Feuille & "$" & Rng & "`"
    rst.Open AdoComand, , 1, 1
    GetLastRowInClosedFich = rst.RecordCount
    AdConn.Close: Set rst = Nothing: Set AdoComand = Nothing: Set AdConn = Nothing
End Function

Sub test()
    Dim chemin$, Fichier$, Rng As Range, Feuille$
    chemin = ThisWorkbook.Path          'chemin du fichier source
    Fichier = "JournalAux-97.xlsx"      'nom du fichier source
    Onglet = "JournalReport"            'feuille du fichier source
    Set Rng = [A1:K1].Resize(Rows.Count)              'plage (colonne)du fichier source a examiner
    
    MsgBox GetLastRowColInClosedFich(chemin, Fichier, Onglet, Rng)
End Sub

Function GetLastRowColInClosedFich(chemin$, Fichier$, Feuille, Rng As Range)
'collection fichiers fermé derniere ligne dans une colonne de fichiers fermé:patricktoulon
    Dim Addr$, Formule, n&, Max&
    For c = 1 To Rng.Columns.Count
        Addr = Rng.Columns(c).Address(, , xlR1C1)
         Formule = "'" & chemin & "\[" & Fichier & "]" & Feuille & "'!" & Addr
        On Error Resume Next
        n = ExecuteExcel4Macro("MATCH(""zzzzz""," & Formule & ")")    'dernière cellule texte en colonne D
        If n > Max Then Max = n
        On Error GoTo 0
    Next
    GetLastRowColInClosedFich = Max
End Function

Sub Power_Query()

With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
End With

Dim T#
T = Timer
    ActiveWorkbook.Queries.Add Name:="JournalReport", Formula:= _
        "let" & Chr(13) & "" & Chr(10) & "    Source = Excel.Workbook(File.Contents(""C:\Users\ilies\Desktop\test\JournalAux.xlsx""), null, true)," & Chr(13) & "" & Chr(10) & "    JournalReport_Sheet = Source{[Item=""JournalReport"",Kind=""Sheet""]}[Data]," & Chr(13) & "" & Chr(10) & "    #""Type modifié"" = Table.TransformColumnTypes(JournalReport_Sheet,{{""Column1"", type any}, {""Column2"", type any}, {""Column3"", type text}, {""Column4"", type text}, {""Column5"", type te" & _
        "xt}, {""Column6"", type text}, {""Column7"", type text}, {""Column8"", type text}, {""Column9"", type any}, {""Column10"", type datetime}, {""Column11"", type any}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Type modifié"""
    ActiveWorkbook.Worksheets.Add
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
        "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=""JournalReport"";Extended Properties=""""" _
        , destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdSql
        .CommandText = Array("SELECT * FROM [JournalReport]")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .ListObject.DisplayName = "JournalReport"
        .Refresh BackgroundQuery:=False
        
    End With
Dim cn As WorkbookConnection, qry As WorkbookQuery
    On Error Resume Next
    For Each cn In ActiveWorkbook.Connections
        cn.Delete
    Next cn
    For Each qry In ActiveWorkbook.Queries
        qry.Delete
    Next qry
MsgBox "Durée " & Format(Timer - T, "0.00 \sec"), , "Import"
With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
End With

End Sub

Sub ADO_VBA()
Dim cn As ADODB.connection
Dim oCat As ADOX.Catalog
Dim Filemane As String
Dim rst As ADODB.Recordset
Dim texte_SQL As String
Dim Ar() As String, i As Long
Dim T#
With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayScrollBars = False
        .ScreenUpdating = False
End With

T = Timer
Filemane = "C:\Users\ilies\Desktop\test\JournalAux.xlsx"
Set cn = New ADODB.connection
Set oCat = New ADOX.Catalog
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & Filemane & ";" & "Extended Properties=""Excel 12.0;HDR=Yes;"";"
Set oCat.ActiveConnection = cn

'For Each Feuille In oCat.Tables
'        i = i + 1
'        ReDim Preserve Ar(i)
'        Ar(i) = Feuille.Name
'Next Feuille



texte_SQL = "SELECT * FROM [JournalReport$]"
 
    Set rst = New ADODB.Recordset
    Set rst = cn.Execute(texte_SQL)
    


Range("A1").CopyFromRecordset rst

Set Feuille = Nothing
Set oCat = Nothing
cn.Close
Set cn = Nothing
MsgBox "Durée " & Format(Timer - T, "0.00 \sec"), , "Import"

With Application
        .Calculation = xlCalculationAutomatic
        .DisplayScrollBars = True
        .EnableEvents = True
        .ScreenUpdating = True
End With


End Sub

#""Type modifié""

{""Column6"", type text}

Rdest.FormulaArray = "=""""&'" & Chemin & "\[" & Fichier & "]" & Onglet & "'!" & CStr(Rsource.Address(0, 0))    'formule matricielle de liaison