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

 

[sylvanu]

Bonjour Iliess,
Les macros "ExecuteExcel4Macro" ne datent pas d'hier, elles sont issues de très vieilles versions d'XL.
En PJ un essai qui copie la plage A1:K26 en conservant les formats d'origine.

 

[iliess]

merci Mr sylvanu pour votre réponse
votre méthode est juste est fonctionne très bien mais le problème se pose dans mon fichier journalAux c'est un fichier très volumineux qui contient plus de 450000 lignes et la duré d'ouverture est plus de 20minutes.
alors la fonction .Open n'est pas utile pour ma question.

 

[sylvanu]

Bonjour,

c'est un fichier très volumineux qui contient plus de 450000 lignes

Effectivement c'est une info très importante. Vous auriez du le préciser au départ.
En PJ un autre essai sans ouvrir le fichier.
Mais cela suppose que la mise en forme est toujours la même.

Sub LireFichierFermé()
    Dim Fichiersource$, Cheminsource$, Formule$
    Application.ScreenUpdating = False
    [A1:K26].ClearContents
    Cheminsource = ThisWorkbook.Path & "\"
    Fichiersource = "JournalAux-97.xlsx"
    Formule = "='" & Cheminsource & "[" & Fichiersource & "]JournalReport'!$A$1:$K$26"
    With Range("$A$1:$K$26")
        .Value = Formule
        .Value = .Value
    End With
    [A1:K26].Replace What:="0", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
End Sub

 

[patricktoulon]

Bonjour
à l'origine elle était en deux parties cette macro et réutilisable en modifiant la partie 1
@sylvanu
.value=une formule ???
a la base c'est une matricielle (formulaarray)

Sub LitClasseurFermé()
    Dim Rsource As Range, Rdest As Range, Chemin$, Fichier$, Onglet$
    Chemin = ThisWorkbook.Path    'chemin du fichier source
    Fichier = "JournalAux-97.xlsx"    'nom du fichier source
    Onglet = "JournalReport"    'feuille du fichier source
    Set Rsource = [A1:k26]    ' plage du fichier source
    Set Rdest = ShDatas.[A1].Resize(Rsource.Rows.Count, Rsource.Columns.Count)    'destination
    LitChamp Rdest, Chemin, Fichier, Onglet, Rsource    'lance l'execution
    ShDatas.Range("A1:K5").Replace What:="0", Replacement:="", LookAt:=xlWhole
End Sub

Sub LitChamp(Rdest As Range, Chemin, Fichier, Onglet, Rsource As Range)
    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
End Sub

 

[iliess]

bonjour @patricktoulon
merci pour votre code
pour une plage de A1:K400000 le temps d'execution est de 130 sec
et après la désactivation de cette ligne

ShDatas.Range("A1:K5").Replace What:="0", Replacement:="", LookAt:=xlWhole

le temps d'execution est de 37 sec
et en plus cette ligne

Rdest = Rdest.Value

le le temps d'execution est de 18 sec
est ce qu'il ya une méthode qui remplacer le 0 sans passer par .replace et diminuer le temps d'execution.
merci

 

[job75]

Bonjour iliess, sylvanu, Patrick,

est ce qu'il ya une méthode qui remplacer le 0 sans passer par .replace et diminuer le temps d'execution.

Modifiez la 2ème macro de Patrick :

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

et dites-nous.

A+

 

[patricktoulon]

Bonjour @job75
l'astuce ne risque t elle pas de transformer toute donnée en texte ??

 

[patricktoulon]

re
j'ai une fonction pour déterminer le end(xlup) dans un fichier fermé aussi si vous voulez
au lieu de A1:k26 on pourrait ajuster

 

[patricktoulon]

ou tu passe par ado avec ma fonction getusedrangeoncolsedfich

ça te dispense de l'élimination des "0"

Sub GetUserRangeOnClosedFich(fichier$, feuille$, destination As Range)
   'patricktoulon
   'version 2021
   Dim Ado As Object, texte_SQL$, AdoReQ As Object
      Set Ado = CreateObject("ADODB.Connection")    'instance d'ado
    With Ado    'Ado Connexion
       ' .Provider = "Microsoft.Jet.OLEDB.4.0"
        .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & fichier & ";Extended Properties=""Excel 12.0;HDR=YES;"""
        .Open
    End With
    texte_SQL = "select * from [" & feuille & "$]" 'adapter le non de la feuill si besoins
    Set AdoReQ = CreateObject("ADODB.Recordset")
    Set AdoReQ = Ado.Execute(texte_SQL)

    'inscrisption du return de AdoReQ a la suite dans le sheets
   destination.CopyFromRecordset AdoReQ
    '--- Fermeture connexion ---
    Ado.Close
    Set Ado = Nothing
End Sub

Sub lance()
Dim fichier$, feuille$, destination As Range
fichier = "C:\Users\patrick1\Desktop\Telechar\JournalAux-97.xlsx"    'chemin du  classeur fermé servant de base de données
feuille = "JournalReport"
Set destination = ShDatas.Cells(1)
GetUserRangeOnClosedFich fichier, feuille, destination
End Sub

 

[patricktoulon]

sinon on diffère un peu on trancrit le recorset de la requete dans une variable tableau ca a pour effet de mettre ce qui est numerique numerique
là aussi on est dispensé du replace "0"

Sub test_récup_plage()
    Dim fichier$, T
    fichier = "C:\Users\patrick1\Desktop\Telechar\JournalAux-97.xlsx"     'à adapter
    T = GetUserRangeOnClosedFich2(fichier, "A1:k26", "JournalReport", False)
    ShDatas.[A1].Resize(UBound(T), UBound(T, 2)) = T
End Sub

'renvoie les valeurs d'une plage de cellules contigües (RnG)
'd'une feuille (Feuille) d'un fichier (fichier) fermé
'le paramètre headerTable indique si la plage a ou non une ligne d'entêtes
Function GetUserRangeOnClosedFich2(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
    'early binding
    'Dim AdConn As ADODB.Connection, AdoComand As ADODB.Command, RsT As ADODB.Recordset
    'Set AdConn = New ADODB.Connection
    'Set RsT = New ADODB.Recordset
    'Set AdoComand = New ADODB.Command

    'late binding
    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")

    HDR = Array("No", "Yes")(Abs(headerTable))

   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
    ReDim Arr(1 To RsT.RecordCount, 1 To RsT.Fields.Count)
    RsT.MoveFirst
    Do While Not RsT.EOF
        For RsTLigne = 1 To RsT.RecordCount  'lignes
            For RsTCol = 0 To RsT.Fields.Count - 1  'colonnes
                Arr(RsTLigne, RsTCol + 1) = RsT.Fields(RsTCol).Value
            Next
            RsT.MoveNext
        Next
    Loop
    AdConn.Close: Set RsT = Nothing: Set AdoComand = Nothing: Set AdConn = Nothing
    GetUserRangeOnClosedFich2 = Arr
End Function

 

[iliess]

re
j'ai une fonction pour déterminer le end(xlup) dans un fichier fermé aussi si vous voulez
au lieu de A1:k26 on pourrait ajuster

oui avec plaisir Mr

 

[patricktoulon]

je l'ai essayé comme c'est encore du Ado ou Macro4 et qu'il y a des fusions de cellule dans le xlsx ca ne peut fonctionner

je t'ai donné 2 autres méthodes avec ado ; prends la 2 elle est très bien elle te fait tout
tu a juste a changer le chemin du fichier chez moi 30 000 lignes c'est quasiment instantané

 

[patricktoulon]

en bloquant le rafraichissement d'ecran c'est encore mieux
regarde sur 10 000 ligne et +

Sub test_récup_plage()
    Dim Fichier$, T
    Fichier = "C:\Users\patrick1\Desktop\Telechar\JournalAux-97.xlsx"     'à adapter
    T = GetUserRangeOnClosedFich2(Fichier, "A1:k100000", "JournalReport", False)
    Application.ScreenUpdating = False
    ShDatas.[A1].Resize(UBound(T), UBound(T, 2)) = T
End Sub

'renvoie les valeurs d'une plage de cellules contigües (RnG)
'd'une feuille (Feuille) d'un fichier (fichier) fermé
'le paramètre headerTable indique si la plage a ou non une ligne d'entêtes
Function GetUserRangeOnClosedFich2(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
    'early binding
    'Dim AdConn As ADODB.Connection, AdoComand As ADODB.Command, RsT As ADODB.Recordset
    'Set AdConn = New ADODB.Connection
    'Set RsT = New ADODB.Recordset
    'Set AdoComand = New ADODB.Command

    'late binding
    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")

    HDR = Array("No", "Yes")(Abs(headerTable))

   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
    ReDim Arr(1 To Rst.RecordCount, 1 To Rst.Fields.Count)
    Rst.MoveFirst
    Do While Not Rst.EOF
        For RsTLigne = 1 To Rst.RecordCount  'lignes
            For RsTCol = 0 To Rst.Fields.Count - 1  'colonnes
                Arr(RsTLigne, RsTCol + 1) = Rst.Fields(RsTCol).Value
            Next
            Rst.MoveNext
        Next
    Loop
    AdConn.Close: Set Rst = Nothing: Set AdoComand = Nothing: Set AdConn = Nothing
    GetUserRangeOnClosedFich2 = Arr
End Function

 

[patricktoulon]

et oui je m'en doutais on a un depacement de capacité à 50 000 lignes
la seule solution est effectivement les formules de liaison

je regarde pour palier au problème de fusion