Microsoft 365 importer une plage d'un fichier fermé

[iliess]

bonjour
après une recherche dans le web j'ai trouvé macro suivant qui importe la valeur de la cellule A1 d'un ficher fermé.
j'ai modifier macro en remplacent la cellule A1 par la plage A1:K10000
mais ca marche pas

 

[iliess]

Mr @patricktoulon
Après votre permission est ce que je peux vous partagé mon fichier journalAux mais pas dans le cite car c'est un fichier uniquement pour notre entreprise

 

[patricktoulon]

re
sauf conception particulière je n'en ai pas besoins
allez regarde
un peu plus de 3 secondes pour 52 000 lignes et 11 colonnes

le code magic'

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

@job75 en fait non ta petite modif ne renvoie pas en texte c'est étonnant

voila @iliess tu a ta fonction
3 secondes sur 50 000 lignes 140 devrait faire moins de 10 secondes

au plaisir

 

[job75]

Modifiez la 2ème macro de Patrick :

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

et dites-nous.

J'aimerais bien que vous nous indiquiez la durée d'exécution sur la plage A1K400000.

 

[patricktoulon]

re
job75 dans mon post #17 j'ai adapté ton astuce
j'ai gonflet son xlsx a plus de 50 000 lignes
la nouvelle fonction j'injecte A1 : K500 000
il me retourne 50012 lignes utilisée(ce qui est exact)
j'injecte donc les formule sur 50012 lignes et pas plus
comme ca on :

1. perd un peu de temps a trouver la last ligne du fichier fermé
2. mais on en gagne en ne faisant que le nombre de lignes necéssaires pour les formules

j'en ai profité pour voir pourquoi celle en macro4 ne fonctionnait pas tout du moins elle donnait un résultat loufoque
en fait c'est quelle n'aime pas les blancs en deux pleines
je l'ai donc repris et fait l'examen colonne par colonne
mais elle reste largement plus longue que celle avec adobd .connection

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

 

[iliess]

bonsoir les amis
et merci pour votre temps et votre aide
voici un resumé
poste #05 la durée d'exécution est de 173 sec
poste #07 la durée d'exécution est de 108 sec
poste #10 la durée d'exécution est de 65 sec
poste #17 la durée d'exécution est de 83 sec

et j'ai ajouter deux méthodes
la premier avec Power QUERY la durée d'exécution est de 28 sec

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

la deuxième avec Les ADO_VBA la durée d'exécution est de 58 sec

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

 

[iliess]

Avec un PC :Intel(R) Core(TM) i5-6400T CPU @ 2.20GHz 8Go da RAM

 

[patricktoulon]

re
c'est normal que le 10 soit moins long c'est du texte donc le format dans les colonnes n'est pas bon
le 17 tout est bon valeurs et format
le query.add (et non power query) c'est pareil c'est du texte c'est pas bon
c'est pour ca que je t'ai fait le 17 en variable tableau (pour l'autoconversion)

 

[Cousinhub]

re
c'est normal que le 10 soit moins long c'est du texte donc le format dans les colonnes n'est pas bon
le 17 tout est bon valeurs et format
le query.add (et non power query) c'est pareil c'est du texte c'est pas bon
c'est pour ca que je t'ai fait le 17 en variable tableau (pour l'autoconversion)

Bonsoir,
Query.Add et Power Query, c'est blanc bonnet et bonnet blanc...
Et pour le format "Texte", juste quelques variables à modifier dans l'étape :

#""Type modifié""

Par exemple,

{""Column6"", type text}

Remplacer text, par number...
Bonne soirée

 

[Usine à gaz]

Bonjour Patrick, Bonjour Gérard, le Forum

@patrick : Je voulais tester ton code mais ça beug :

Ai-je oublié un truc ?

 

[patricktoulon]

re

Bonjour Lionel
ben si tu n'a pas de feuille avec un codename "ShDatas" ça risque pas de marcher

 

[job75]

Bonjour Lionel, le fil,

Tu remarqueras dans le code de Patrick que ShDatas n'est pas une variable.

C'est donc le CodeName de la feuille.

A+

 

[patricktoulon]

re
à ben ca va marcher beaucoup moins bien forcément

 

[Usine à gaz]

ben si tu n'a pas de feuille avec un codename "ShDatas" ça risque pas de marcher ?
Je sais j'suis nul : je fais koi ?

 

[Usine à gaz]

Bon sang, "la tache" ... OK, c'est bon

 

[patricktoulon]

en tout cas Merci @job75 pour l'astuce
je n'aurais jamais cru a l'autoconversion numérique avec ça

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