Lire un fichier Excel sans l'ouvrir avec VBA [Résolu]

'————————————————————————————————————————————————————————————————————————————————————————————————————————————————
' Module    : mImportCsvFiltre
' Objet     : Lecture et filtrage ligne à ligne d'un gros fichier cvs UTF8
'————————————————————————————————————————————————————————————————————————————————————————————————————————————————
' 21/12/2020    Patrice33740        V1-0-00  Création
'
' Établir la référence à ADODB :  Microsoft ActiveX Data Objects 6.1 Library
'
Option Explicit
'
' Séparateurs
Const sepL$ = vbCrLf                                 'séparateur de lignes
Const sepV$ = ";"                                    'séparateur de valeurs
Const idTxt$ = """"                                  'identificateur de texte chr(34)
'

Sub Lire_csv_UTF8_filtre()
' Choix et lecture du fichier csv en filtrant
'
Dim wbk As Workbook
Dim nomComplet As Variant, colonne As Long, filtre As Variant

  On Error Resume Next
  colonne = Feuil1.Columns(Feuil1.Range("E4").Value).Column
  If Err <> 0 Then MsgBox "Colonne erronée", vbCritical: Exit Sub
  On Error GoTo 0
  If Feuil1.Range("E5").Text = "" Then MsgBox "Préciser la valeur à filtrer", vbExclamation: Exit Sub
  filtre = Feuil1.Range("E5").Value
  ' Choix fichier
  nomComplet = ChoisirFichier(".csv", ThisWorkbook.Path & "\")
  If nomComplet = "" Then Exit Sub
  Set wbk = Lire_Filtrer_csv_UTF8(nomComplet, colonne, filtre)
  wbk.Saved = True

End Sub

Private Function Lire_Filtrer_csv_UTF8(ByVal nomCompletFichier As String, col As Long, filtre As Variant) As Workbook
' Lecture et filtrage ligne à ligne d'un [très gros] fichier au format csv encodé UTF8 (avec ou sans BOM)
'
Dim fUtf8 As ADODB.Stream
Dim wbk As Excel.Workbook
Dim cel As Range
Dim txt As String
Dim lgn As String
Dim lgr As Long

  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Set wbk = Application.Workbooks.Add(xlWBATWorksheet)
  Set cel = wbk.Worksheets(1).Range("A1")
  Set fUtf8 = New Stream
  With fUtf8
    .Charset = "utf-8"
    .Mode = adModeReadWrite
    .Type = adTypeText
    .LineSeparator = adCRLF
    .Open
    .LoadFromFile nomCompletFichier
    Do Until .EOS
      lgn = .ReadText(-2)         '-2 = une ligne
      If cel.Row = 1 Then
        Call EcrireLigneCSV(lgn, cel)
      Else
        Call FiltrerLigneCSV(lgn, cel, col, filtre)
      End If
    Loop
    .Close
  End With
  Set fUtf8 = Nothing
  wbk.Worksheets(1).Columns.AutoFit
  wbk.Worksheets(1).Rows.AutoFit
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  Set Lire_Filtrer_csv_UTF8 = wbk
  
End Function

Private Sub FiltrerLigneCSV(lgn As String, cel As Range, col As Long, filtre As Variant)
' Filtrage et écriture d'une ligne d'un fichier au format csv
'
Dim txt As String
Dim frm As String
Dim lgr As Long
Dim nbC As Long
Dim t As Variant
Dim i As Long
  
  If lgn = "" Then Exit Sub
  t = Split(lgn, sepV)
  If t(col - 1) = filtre Then
    For i = LBound(t) To UBound(t)
      cel.Offset(0, nbC).FormulaLocal = t(i)
      nbC = nbC + 1
    Next i
    Set cel = cel.Offset(1)
  End If
End Sub

Private Sub EcrireLigneCSV(lgn As String, cel As Range)
' Ecriture d'une ligne d'un fichier au format csv
'
Dim txt As String
Dim frm As String
Dim lgr As Long
Dim nbC As Long
Dim t As Variant
Dim i As Long
  
  If lgn = "" Then Exit Sub
  t = Split(lgn, sepV)
  For i = LBound(t) To UBound(t)
    cel.Offset(0, nbC).FormulaLocal = t(i)
    nbC = nbC + 1
  Next i
  Set cel = cel.Offset(1)
End Sub

Private Function ChoisirFichier(ByVal strExtension As String, Optional ByVal strChemin As String = "") As String
' Choix d'un fichier
'
Dim dlgParcourir As FileDialog
  
  If strChemin = "" Then strChemin = ThisWorkbook.Path
  Set dlgParcourir = Application.FileDialog(msoFileDialogFilePicker)
  With dlgParcourir
    .InitialFileName = strChemin
    .Title = "Sélectionner un fichier " & strExtension & " :"
    .AllowMultiSelect = False
    .InitialView = msoFileDialogViewDetails
    .ButtonName = "Sélection fichier"
    If .Filters.Count > 0 Then .Filters.Delete
    .Filters.Add "Fichiers " & strExtension, "*" & strExtension, 1
    If .Show = -1 Then ChoisirFichier = .SelectedItems(1) Else ChoisirFichier = ""
  End With
  Set dlgParcourir = Nothing

End Function