XL 2021 import-informations-classeurs-fermes

chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "fichier*.xlsm")

Option Explicit
Sub RequeteClasseurFermeLionel()
' Le classeur qui établie la connexion
Dim Wkb As Workbook, Wks As Worksheet
    Set Wkb = ThisWorkbook
    Set Wks = Wkb.Worksheets("RdV_transfert")
' Les Fichiers "fichier*.xlsm" (les Base de données "Feuille RdV_transfert")
Dim chemin As String
Dim Fich As String
    chemin = ThisWorkbook.Path & "\"
    Fich = Dir(chemin & "fichier*.xlsm") ' 1er fichier du dossier
    If Fich = "" Then MsgBox "Aucun fichier de facturation trouvé...": Exit Sub
' Date (Pour la ou les condition)
Dim date1 As Date ' La date D'aujourd'hui
Dim date2 As Date ' La Date en B2
Dim date3 As Date ' La Date en C2
Dim dif As Long   ' L'ecart entre deux date

' Sauf les entêtes (zone a modifier en fonction des besoin)
    Wks.Range("A2:AG65536").ClearContents

' Boucle
    While Fich <> ""
'   Les connecteurs
    Dim Cn As ADODB.Connection  ' La Connection
    Dim Rst  As ADODB.Recordset ' La Recordset
    Dim TDon() As Variant       ' Pour la récupération du Recordset dans une variable tableau de type Variant
    Dim TRes() As Variant       ' Pour récupérer le resultat de la requêtte à Lionel
    Dim i As Long, j As Long
    Dim fichier As String
    Dim NomFeuille As String    ' Le nom de la feuille (dans le classeur source qui est la base de donnée "RdV_transfert"
    Dim texte_SQL As String     ' La requête (Pour récupérer la table du classeur excel Fermé soit la Feuille "RdV_transfert"
    ' Chemin complet du classeur fermé (servant de base de données)
        fichier = chemin & Fich ' Chemin complet du classeur fermé qui contient la base de donnée.
    'Nom de la feuille dans le classeur fermé
        NomFeuille = CStr(Wks.Name) ' Soit l'onglet du classeur fermé qui contient la base de donnée (La table) "RdV_transfert"
    '--- Connection ---
            '--- Connection ---
    Set Cn = New ADODB.Connection
    With Cn
        .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
    '-----------------
    'Définit la requête.
    '/!\ Attention à ne pas oublier le symbole $ après le nom de la feuille.
    texte_SQL = "SELECT * FROM [" & NomFeuille & "$]"
    '-----------------
    Set Rst = New ADODB.Recordset
    Set Rst = Cn.Execute(texte_SQL)
      
    'Exemple 1: Ecrit le résultat de la requête "Rst" dans la cellule (Ici A2 pour Exemple)
    'Range("A18").CopyFromRecordset Rst
      
    'Exemple 2 :  Ecrit le résultat de la requête "Rst" dans la variable tableau TDon
     TDon = Rst.GetRows
  
            ReDim TRes(LBound(TDon, 1) + 1 To UBound(TDon, 1) + 1, 1 To 1)
            For i = LBound(TDon, 2) To UBound(TDon, 2)
                date1 = Format(Now, "dd/mm/yyyy")
                date2 = TDon(2, i)
                date3 = Format(TDon(1, i), "dd/mm/yyyy")
            If (date2 = date1 And (date3 - date2) > 3) Or (date2 = date1 And (date2 - date3) > 3) Then
                For j = LBound(TDon, 1) To UBound(TDon, 1)
                    TRes(j + 1, UBound(TRes, 2)) = TDon(j, i)
                Next j
                ReDim Preserve TRes(LBound(TRes, 1) To UBound(TRes, 1), 1 To UBound(TRes, 2) + 1)
            End If
            Next i
          
            On Error Resume Next
            ReDim Preserve TRes(LBound(TRes, 1) To UBound(TRes, 1), 1 To UBound(TRes, 2) - 1)
            If Err = 0 Then
            ' Option 1 :Resultat avec Application.Transpose(TRes)
                'Wks.Cells(Wks.Cells(65536, 1).End(xlUp).Row + 1, 1).Resize(UBound(TRes, 2), UBound(TRes, 1)) = Application.Transpose(TRes)
          
            ' Option 2 : Resultat avec avec conversion (Tableau de grande capacité)
                i = Empty: j = Empty: Erase TDon
                ReDim TDon(LBound(TRes, 2) To UBound(TRes, 2), LBound(TRes, 1) To UBound(TRes, 1))
                    For i = LBound(TRes, 2) To UBound(TRes, 2)
                        For j = LBound(TRes, 1) To UBound(TRes, 1)
                            TDon(i, j) = TRes(j, i)
                        Next j
                    Next i
                Wks.Cells(Wks.Cells(65536, 1).End(xlUp).Row + 1, 1).Resize(UBound(TDon, 1), UBound(TDon, 2)) = TDon
            End If
            On Error GoTo 0
  
    '--- Fermeture connexion ---
    Rst.Close
    Set Rst = Nothing
    Set Cn = Nothing
    Erase TRes: Erase TDon
    i = Empty: j = Empty
    Fich = Dir()
    Wend
End Sub

Sub Import()
Dim t#, chemin$, fichier$, feuille$, ncol%, dest As Range, form$, h As Variant, n&
t = Timer
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "fichier*.xlsm") '1er fichier du dossier
If fichier = "" Then MsgBox "Aucun fichier de facturation trouvé..."
feuille = "RdV_transfert"
ncol = 11 'nombre de colonnes à copier dans la feuille source (A:K)
Set dest = Sheets("RdV_transfert").[A1] '1ère cellule du tableau, à adapter
Application.ScreenUpdating = False
If dest.Parent.FilterMode Then dest.Parent.ShowAllData 'si la feuille est filtrée
dest(2).Resize(Rows.Count - dest.Row, ncol).Delete xlUp 'RAZ
While fichier <> ""
    form = "'" & chemin & "[" & fichier & "]" & feuille & "'!"
    h = ExecuteExcel4Macro("MATCH(""zzz""," & form & "C1)") 'recherche du dernier texte en colonne 1
    If IsNumeric(h) Then
        If h > 1 Then 'à partir de la ligne 2
            With dest(2).Offset(n).Resize(h - 1, ncol)
                .FormulaArray = "=TRIM(" & form & "R2C1:R" & h & "C" & ncol & ")" 'formule de liaison matricielle
                .Value = .Value 'supprime les formules
            End With
            n = n + h - 1
        End If
    End If
    fichier = Dir 'fichier suivant
Wend
'---supprime les lignes dont les dates ne conviennent pas---
If n Then
    dest(1, ncol + 1).EntireColumn.Insert 'insère une colonne auxiliaire
    With dest(2, ncol + 1).Resize(n) 'en colonne L
        .Formula = "=1/AND(C2=TODAY(),SUBSTITUTE(SUBSTITUTE(B2,"" "",""/"",1),"" "",""/"",1)-C2>3)" 'critère de filtrage
        .Value = .Value 'supprime les formules
        .EntireRow.Sort .Cells, xlAscending, Header:=xlNo 'tri pour regrouper et accélérer
        On Error Resume Next 'si aucune SpecialCell
        .SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete 'supprime les valeurs d'erreur
        On Error Resume Next
    End With
    dest(1, ncol + 1).EntireColumn.Delete 'supprime la colonne auxiliaire
End If
n = dest.Parent.UsedRange.Rows.Count - 1
'---mise en forme---
If n Then
    With dest(2).Resize(n, ncol)
        .Borders.Weight = xlHairline
        .BorderAround Weight:=xlThin 'pourtour
    End With
End If
'dest.Parent.Columns.AutoFit 'ajustement largeurs
Application.ScreenUpdating = True
MsgBox "Durée " & Format(Timer - t, "0.00 \s"), , "RdV_transfert"
End Sub

.Formula = "=1/AND(INT(--SUBSTITUTE(SUBSTITUTE(B2,"" "",""/"",1),"" "",""/"",1))=TODAY(),TODAY()-C2>3)" 'critère de filtrage