[VBA] - Importer un document .csv dans une variable tableau sans l'ouvrir

Bonsoir,

Cette discussion fait suite à celle-ci :

https://forum.excel-pratique.com/excel/vba-importer-un-document-csv-dans-une-variable-tableau-sans-l-ouvrir-146945

Pour laquelle j'avais eu une réponse qui convenait à ce que j'essayais de faire à ce moment.

Depuis mon projet a un peu évolué et la taille de la base de données à charger est légèrement plus grande (6300 lignes...).

Il se trouve que l'exécution de la macro n'est plus possible, elle prend beaucoup de temps puis engendre l'arrêt du fonctionnement d'Excel.

Ce que je cherche à faire :

Charger une base de données sans l'ouvrir, format .csv séparateur "," ou ";" (dépend de la source) dans une variable tableau.

Le code qui m'a été proposé par Patrice33740, que je remercie encore ! , fonctionnait au départ, mais là j'ai du mal à la faire tourner.

Existe t-il une méthode plus simple / rapide ? La méthode de Patrice33740 utilise différentes fonctions avec plusieurs boucles et est plutôt complexe à bien comprendre !

Voici un document zippé contenant la base de données ainsi que la partie du code qui charge la bdd dans une variable tableau.

16bases-de-donnees.zip (315.88 Ko)

Normalement, si vous tentez de lancer la macro, il y ne se passera rien, et Excel se figera.
J'espère que vous y verrez clair dans les macro, autrement j'épurerai un peu en enlevant des parties inutiles.

Je vous remercie de votre attention ! Bonne soirée !

La macro ci-après. (Dommage que le bouton spoiler n'existe plus)

Option Explicit
Public chk2 As Byte, chk2a As Byte, chk2b As Byte, chk2c As Byte, chk2d As Byte, chk2e As Byte, chk2f As Byte, chk2g As Byte, compteur1 As Byte, compteur2 As Byte, compteur3 As Byte, compteur4 As Byte, compteur5 As Byte, compteur5b As Byte, compteur6 As Byte, _
compteur10 As Byte, compteur11 As Byte, compteur12 As Byte, compteur13 As Byte, compteur14 As Byte, compteur15 As Byte, compteur16 As Byte, compteur17 As Byte, compteur18 As Byte, compteur7 As Byte, compteur8 As Byte, compteur8b As Byte, compteur9 As Byte, cib31g As Byte, _
cib0 As Byte, cib1 As Byte, cib2 As Byte, cib3 As Byte, cib4 As Byte, cib5 As Byte, cib6 As Byte, cib7 As Byte, cib8 As Byte, cib9 As Byte, cib25 As Byte, cib26 As Byte, cib27 As Byte, cib28 As Byte, cib29 As Byte, cib30 As Byte, cib31d As Byte, cib31e As Byte, cib31f As Byte, _
cib10 As Byte, cib11 As Byte, cib12 As Byte, cib13 As Byte, cib14 As Byte, cib15 As Byte, cib16 As Byte, cib17 As Byte, cib18 As Byte, cib19 As Byte, cib20 As Byte, cib21 As Byte, cib22 As Byte, cib23 As Byte, cib24 As Byte, cib31 As Byte, cib31c As Byte, cib31b As Byte, _
Va As Byte, Vb As Byte, Vc As Byte, Vd As Byte, Ve As Byte, Vf As Byte, Vg As Byte, chk42 As Byte, tL As Variant, LLtL%, cib32 As Byte, cib18a As Byte, cib18b As Byte, cib18c As Byte, cib18d As Byte, cib18e As Byte, cib18f As Byte, cib18g As Byte, cib31a As Byte, chk52 As Byte

Public chk44 As Byte 'ajouté

Dim sepV$

Option Private Module
' Encodages
Public Const UTF7$ = "utf-7"
Public Const UTF8$ = "utf-8"
Public Const ANSI$ = "iso-8859-1" ' = "ascii", "latin1"
Public Const UNICODE = "unicode"
'
' Séparateurs
Public Const sFrV$ = ";"          'séparateur français de valeurs
Public Const sEnV$ = ","          'séparateur anglais de valeurs
Public Const sepL$ = vbLf         'séparateur de lignes (uniformisé)
Public Const idTxt$ = """"        'identificateur de texte = chr(34)

Public Sub import_data3() 'Merci Patrice33740 ; Excel-Pratique https://forum.excel-pratique.com/excel/vba-importer-un-document-csv-dans-une-variable-tableau-sans-l-ouvrir-146945
Dim myfile$, csv As Variant, a&, e As Byte, monrep$, fich$, lastfich$, ddt As Date, tp As Byte
sepV$ = ",": tp = 0

If ActiveSheet.Name <> "BDD_SAISIE_FLORE" Then
    chk2 = 0: LLtL = 0: chk44 = 0: e = 0: myfile = ChoisirFichier(".csv")
End If

If ActiveSheet.Name = "BDD_SAISIE_FLORE" Then
2 chk2 = 0: LLtL = 0: chk44 = 0: e = 0
  myfile = ThisWorkbook.Path & "\" 'Bases de données\" 'enlevé pour l'exemple
  fich = Dir(myfile & "*BDD_SAISIE_FLORE_*" & "*.csv")
  ddt = DateSerial(1, 1, 1)
  Do While fich <> ""
    If FileDateTime(myfile & fich) > ddt Then
      lastfich = myfile & fich
      ddt = FileDateTime(myfile & fich)
    End If
    fich = Dir
  Loop
End If

If myfile = "" Then chk2 = chk2 + 1: Exit Sub
myfile = lastfich: csv = Tableau_csv_UTF8(myfile)
    If chk44 = 1 Then Exit Sub

  LLtL = UBound(tL, 2) 'temporaire

1  If LLtL = 1 And tp = 0 Then
    MsgBox "Une erreur dans l'import est survenue, délimitateur modifié, import relancé": tp = 1: sepV$ = ";": GoTo 2
  ElseIf tp = 2 Then MsgBox "L'import à échoué après 2 tentatives"
  End If
'Exit Sub
End Sub

Function ChoisirFichier(ByVal strExtension As String, Optional ByVal strChemin As String = "") As String

Dim dlgParcourir As FileDialog

  'Repertoire par défaut : celui de cette macro
  If strChemin = "" Then strChemin = ThisWorkbook.Path
  'Créer une boite de dialogue Parcourir fichier
  Set dlgParcourir = Application.FileDialog(msoFileDialogFilePicker)
  'Selectionner le fichier
  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

Public Function Tableau_csv_UTF8(ByVal nomCompletFichier As String, Optional sepL As String = vbLf)
' Lecture d'un fichier au format csv encodé UTF8 (avec ou sans BOM) dans tableau de lignes
' Pour les valeurs de Stream.Charset, voir dans le registre : HKEY_CLASSES_ROOT\MIME\Database\Charset

'Const sepV$ = ";"                  'séparateur de valeurs
Dim fUtf8 As ADODB.Stream, txt$ 'wbk As Excel.Workbook, lgr&, nL&, t As Variant, i&, cel As Range, lgn$

On Error GoTo Err
  Set fUtf8 = New Stream
  With fUtf8
    ' Définir le flux de données Utf8
    .Charset = "utf-8"
    .Mode = adModeReadWrite
    .Type = adTypeText
    If sepL = vbLf Then
      .LineSeparator = adLF
    ElseIf sepL = vbCrLf Then
      .LineSeparator = adCRLF
    ElseIf sepL = vbCr Then
      .LineSeparator = adCR
    End If
    ' Ouvrir le flux et charger le contenu du fichier
    .Open
    .LoadFromFile nomCompletFichier
    txt = .ReadText
    .Close
  End With
  Set fUtf8 = Nothing
  If Right(txt, Len(sepL)) = sepL Then txt = Left(txt, Len(txt) - Len(sepL))
  If txt > "" Then
    ' Traitement csv
    tL = TableauCSV(txt, sepV)
    If IsEmpty(tL) Then
      MsgBox "Ce fichier est vide.", vbCritical
    Else
      Tableau_csv_UTF8 = tL
    End If
  Else
    MsgBox "Ce fichier est vide.", vbCritical
  End If

Exit Function
Err:
MsgBox "Le fichier ne peut pas être ouvert, vérifiez qu'il n'est pas déjà utilisé par un autre logiciel (ex : QGIS)": chk44 = 1
End Function

Private Function TableauCSV(strCSV As String, sepV As String) As Variant
' Transpose le texte d'un fichier csv dans un tableau excel à 2 dimensions
Dim result As Variant, lignes As Variant, champs As Variant, ligne$, nbl&, nbC&, noL&, noC&

  lignes = SplitCSV(strCSV, vbLf)
  nbl = UBound(lignes)
  If lignes(nbl) = "" Then nbl = nbl - 1
  ligne = lignes(1)               'ligne des libellés
  nbC = UBound(SplitCSV(ligne, sepV))
  On Error GoTo Lp_Error
  ReDim result(1 To nbl, 1 To nbC)
  For noL = 1 To nbl
    ligne = lignes(noL)
    champs = SplitCSV(ligne, sepV)
    For noC = 1 To nbC
      result(noL, noC) = champs(noC)
    Next noC
  Next noL
  On Error GoTo 0
  TableauCSV = result

Exit Function
Lp_Error:
  MsgBox "Erreur dans la procédure TableauCSV du module mCSV :" & vbCrLf & _
         "Erreur" & Err.Number & " (" & Err.Description & ")"

End Function

Private Function SplitCSV(strCSV As String, ByVal sep As String) As Variant
' Transpose les infos d'une chaine ASCII au format CSV séparées par sep dans un tableau d'infos
Dim infos() As String, splits As Variant, info As String, n°I&, n°S&

  ' Traiter les enregistrements CSV :
  ' - uniformiser les séparateurs de ligne (selon l'origine, la ligne CSV est terminé par Cr ou CrLf ou Lf)
  strCSV = Replace(Replace(strCSV, vbCrLf, vbLf), vbCr, vbLf)
  If sep = vbCr Or sep = vbCrLf Then sep = vbLf
  ' - fractionner la chaine à chaque séparateur (y compris ceux dans le texte)
  splits = Split(strCSV, sep)
  ' Extraire les infos entières
  Do While n°S <= UBound(splits)
    'Extraire une info complète à partir de n°S
    info = LireInfoCSV(splits, sep, n°S)
    If sep = "," Then
      ' C'est une valeur de champ
      If Left(info, 1) = idTxt Then
        ' le texte est délimité, enlever les délimiteurs
        info = Mid(info, 2, Len(info) - 2)
        ' remplacer les doubles délimiteurs pas un simple délimiteur
        info = Replace(info, idTxt & idTxt, idTxt)
      End If
    End If
    ' L'ajouter au tableau
    n°I = n°I + 1
    ReDim Preserve infos(1 To n°I)
    infos(n°I) = info
  Loop
  SplitCSV = infos
  Erase infos

End Function

Private Function LireInfoCSV(splits As Variant, sep As String, n°S As Long) As String
' Extrait une information CSV complète (ligne ou valeur) de la table splits :
'  la chaine CSV ayant été fractionnée à chaque séparateur, les informations CSV contenant un séparateur (CrLf
'  ou ,) à l'intérieur d'un texte (entre le quote (") de début et celui de fin) se retrouvent fractionnés dans
'  la table splits. Cette procédure reconstitue les informations complètes.
' A la sortie n°S pointe l'enregistrement suivant.
Dim infoSuiv$, ptr&, NbIdTxtImpair As Boolean 'vrai si le nombre d'identificateur de texte (") est impair

  LireInfoCSV = splits(n°S)
  n°S = n°S + 1
  NbIdTxtImpair = EstNbIdTxtImpair(LireInfoCSV)
  Do While NbIdTxtImpair And (n°S <= UBound(splits))
    infoSuiv = splits(n°S)
    LireInfoCSV = LireInfoCSV & sep & infoSuiv
    ptr = InStr(1, infoSuiv, idTxt)
    If ptr > 0 Then
      infoSuiv = Mid(infoSuiv, ptr + 1)
      NbIdTxtImpair = EstNbIdTxtImpair(infoSuiv)
    End If
    n°S = n°S + 1
  Loop

End Function

Private Function EstNbIdTxtImpair(ByVal txt As String) As Boolean
  EstNbIdTxtImpair = (Len(txt) - Len(Replace(txt, idTxt, ""))) Mod 2 = 1
End Function

Bonjour,

Je peux proposer une méthode par Sql.

Pour cela, une préparation est à faire :

* on crée un fichier schema.ini reprenant les entêtes du csv (avec le Bloc-notes de windows par exemple)

* on supprime la litanie des virgules inutiles en fin de lignes (un simple chercher-remplacer avec Notepad++)

* enfin avec un code très simple on lit le contenu (code ci-dessous)

(les 3 fichiers du zip sont à décompresser dans un même dossier)

Pierre

Sub Import_CSV()
Dim ndf As String, T As Variant

    ndf = CSV_A_LIRE
    ndf = Replace(ndf, ThisWorkbook.Path & "\", "")

    Req = "SELECT `globalid_fo`,`uniquerowid`,`numero_etude`,`placette`,`autres_infos`," & _
          "`date`,`created_date_fo`,`created_user_fo`,`last_edited_date_fo`," & _
          "`last_edited_user_fo`,`x`,`y`,`objectid`,`globalid_sa`,`especes`,`abondance`," & _
          "`remarque`,`parentrowid`,`created_date_sa`,`created_user_sa`,`last_edited_date_sa`," & _
          "`last_edited_user_sa`,`parrentrowid_indiv`,`parrentrowid_indiv` FROM [" & ndf & "] "

    Connect_Csv ThisWorkbook.Path & "\"
    T = Select_Db(Req, 1)
    Close_Cnx
    ActiveSheet.Range("A1").Resize(UBound(T, 1), UBound(T, 2)) = T

End Sub
14demo-csv.zip (385.41 Ko)

On peut même simplifier la requête si on veut tous les champs :

Sub Import_CSV()
Dim ndf As String, T As Variant

    ndf = CSV_A_LIRE
    ndf = Replace(ndf, ThisWorkbook.Path & "\", "")

    Req = "SELECT * FROM [" & ndf & "] "

    Connect_Csv ThisWorkbook.Path & "\"
    T = Select_Db(Req, 1)
    Close_Cnx
    ActiveSheet.Range("A1").Resize(UBound(T, 1), UBound(T, 2)) = T

End Sub

nb : dans la première proposition, il est possible de sélectionner uniquement les champs souhaités. Ici pour les 2 premiers par exemple :

Req = "SELECT `globalid_fo`,`uniquerowid` FROM [" & ndf & "] "

Bonsoir,

Le résultat est idéal, mais n'existe t-il pas de solutions pour se passer du Bloc note ou de Notepad++ pour obtenir le même résultat ?

Je ne sais pas comment va évoluer la base de données, au niveau du nombre de colonnes et je me demande si le tout continuera de fonctionner dans le cas où il y aurait des changements dans la BDD ?

En tout cas, je vous remercie pour votre proposition ! Je vais réfléchir si je trouve une solution pour répondre à mes questions ci-dessus.

Bonne soirée !

Re,

Alors je constate qu'en supprimant schema et lorsque je change le nom de la base de données importée (ce qui arrive à chaque enregistrement avec la mise à jour de la date d'enregistrement) ; la macro s'exécute tout aussi bien.

Où est-ce que je vais avoir des problèmes du coup ??

Edit : En effet, si j'essaie d'exécuter cette macro depuis mon document de travail et en allant directement chercher le fichier j'ai cette erreur inscrite en cellule A1 : "Erreur n°-2147217865
[Microsoft][Pilote ODBC Texte] Le moteur de base de données Microsoft Jet n'a pas pu trouver l'objet 'Bases de données\BDD_SAISIE_FLORE_2020_12_31_9.csv'. Assurez-vous que l'objet existe et que vous avez correctement saisi son nom et son chemin d'accès."

Bonjour,

Je me demande s'il ne va pas falloir plutôt que je charge la BDD dans une feuille Excel et que je travaille sur cette feuille chargée. Une fois terminé, la BDD peut être exportée facilement et je peux très simplement la mettre dans une variable tableau si j'en ai vraiment besoin.

Mais suivant la taille de la BDD, ça peut prendre du temps.

Bonne journée !

A plus tard

Rechercher des sujets similaires à "vba importer document csv variable tableau ouvrir"