XL 2010 import fichier .vcf dans excel

sri75 · 28 Juin 2024

Bonjour, je récupère des fichiers .vcf sur des sites et je voudrais les importer ensuite via une macro dans Excel, en récupérant chaque donnée dans une cellule distincte si possible, et sur une ligne et non en colonne

j'ai beau écumer les forums je ne trouve rien de satisfaisant par rapport à mon besoin, je mets en pj un exemple ( j'ai rajouté un .txt à l'extension .vcf pour pouvoir la télécharger )

Je vous remercie tous par avance pour votre aide et vos conseils.

Bonne journée

wDog66 · 28 Juin 2024

Bonjour sri75

Peut-être quelque chose comme ça (dixit GPT )

VB:

Sub ImportVCF()
    Dim filePath As String
    Dim fileNum As Integer
    Dim fileLine As String
    Dim name As String
    Dim phone As String
    Dim email As String
    Dim ws As Worksheet
    Dim row As Long
    
    ' Définir le chemin du fichier VCF
    filePath = "C:\path\to\your\file.vcf"
    
    ' Ouvrir le fichier VCF
    fileNum = FreeFile
    Open filePath For Input As fileNum
    
    ' Créer une nouvelle feuille de calcul pour les données importées
    Set ws = ThisWorkbook.Worksheets.Add
    ws.Name = "VCF Data"
    
    ' Initialiser la première ligne
    row = 1
    
    ' Lire chaque ligne du fichier VCF
    Do While Not EOF(fileNum)
        Line Input #fileNum, fileLine
        
        ' Vérifier si la ligne contient les informations pertinentes
        If InStr(fileLine, "FN:") > 0 Then
            name = Mid(fileLine, InStr(fileLine, "FN:") + 3)
        ElseIf InStr(fileLine, "TEL:") > 0 Then
            phone = Mid(fileLine, InStr(fileLine, "TEL:") + 4)
        ElseIf InStr(fileLine, "EMAIL:") > 0 Then
            email = Mid(fileLine, InStr(fileLine, "EMAIL:") + 6)
        ElseIf InStr(fileLine, "END:VCARD") > 0 Then
            ' Lorsque l'on atteint la fin d'une vCard, écrire les données dans Excel
            ws.Cells(row, 1).Value = name
            ws.Cells(row, 2).Value = phone
            ws.Cells(row, 3).Value = email
            
            ' Passer à la ligne suivante
            row = row + 1
            
            ' Réinitialiser les variables
            name = ""
            phone = ""
            email = ""
        End If
    Loop
    
    ' Fermer le fichier VCF
    Close fileNum
    
    MsgBox "Importation terminée!"
End Sub

sri75 · 28 Juin 2024

wDog66 à dit:

Bonjour sri75

Peut-être quelque chose comme ça (dixit GPT )

VB:

Sub ImportVCF()
    Dim filePath As String
    Dim fileNum As Integer
    Dim fileLine As String
    Dim name As String
    Dim phone As String
    Dim email As String
    Dim ws As Worksheet
    Dim row As Long
   
    ' Définir le chemin du fichier VCF
    filePath = "C:\path\to\your\file.vcf"
   
    ' Ouvrir le fichier VCF
    fileNum = FreeFile
    Open filePath For Input As fileNum
   
    ' Créer une nouvelle feuille de calcul pour les données importées
    Set ws = ThisWorkbook.Worksheets.Add
    ws.Name = "VCF Data"
   
    ' Initialiser la première ligne
    row = 1
   
    ' Lire chaque ligne du fichier VCF
    Do While Not EOF(fileNum)
        Line Input #fileNum, fileLine
       
        ' Vérifier si la ligne contient les informations pertinentes
        If InStr(fileLine, "FN:") > 0 Then
            name = Mid(fileLine, InStr(fileLine, "FN:") + 3)
        ElseIf InStr(fileLine, "TEL:") > 0 Then
            phone = Mid(fileLine, InStr(fileLine, "TEL:") + 4)
        ElseIf InStr(fileLine, "EMAIL:") > 0 Then
            email = Mid(fileLine, InStr(fileLine, "EMAIL:") + 6)
        ElseIf InStr(fileLine, "END:VCARD") > 0 Then
            ' Lorsque l'on atteint la fin d'une vCard, écrire les données dans Excel
            ws.Cells(row, 1).Value = name
            ws.Cells(row, 2).Value = phone
            ws.Cells(row, 3).Value = email
           
            ' Passer à la ligne suivante
            row = row + 1
           
            ' Réinitialiser les variables
            name = ""
            phone = ""
            email = ""
        End If
    Loop
   
    ' Fermer le fichier VCF
    Close fileNum
   
    MsgBox "Importation terminée!"
End Sub

Bonjour, la macro plante a la ligne ws.Name = "VCF Data"

Merci

wDog66 · 28 Juin 2024

Re,

Vous avez bien créé un classeur avec un module contenant ce code !?
Ca ne peut pas planter au niveau de cette ligne

A+

sylvanu · 28 Juin 2024

Bonjour Sri, wDog,
Un autre exemple avec :

VB:

Sub Import()
Dim NomFichier$, N%, T, Tablo, i%
NomFichier = Application.GetOpenFilename("Text files (*.vcf*), *.vcf*", , "CHOISSISSEZ LE FICHIER A TRAITER", , False)
If NomFichier = "Faux" Then Exit Sub
ReDim T(1, 20)          ' Déclare array
Fichier = FreeFile
Open NomFichier For Input As #Fichier
Line Input #Fichier, Ligne
Close #Fichier          ' Fermeture fichier texte
' Restitution du tableau séparateur chr(10
Tablo = Split(Ligne, Chr(10))
For i = 0 To UBound(Tablo)
    On Error Resume Next
    Cells(1, i + 1) = Replace(Split(Tablo(i), ":")(1), ";", " ") ' Ligne 1 à modifier suivant besoin
Next i
End Sub

A adapter suivant votre contexte, traitement de multiples fichiers ou autre.

sri75 · 28 Juin 2024

Ca marche pour le stockage mais c'est le decoupage qui pose pb

ca fonctionne jusqu'a name, ca stoke toute les infos, puis ca passe à end if, loop et puis ca ferme la macro

en fait name contient toutes des données

If InStr(fileLine, "FN:") > 0 Then
name = Mid(fileLine, InStr(fileLine, "FN:") + 3)
ElseIf InStr(fileLine, "TEL:") > 0 Then
phone = Mid(fileLine, InStr(fileLine, "TEL:") + 4)
ElseIf InStr(fileLine, "EMAIL:") > 0 Then
email = Mid(fileLine, InStr(fileLine, "EMAIL:") + 6)
ElseIf InStr(fileLine, "END:VCARD") > 0 Then

sri75 · 28 Juin 2024

sylvanu à dit:

Bonjour Sri, wDog,
Un autre exemple avec :

VB:

Sub Import()
Dim NomFichier$, N%, T, Tablo, i%
NomFichier = Application.GetOpenFilename("Text files (*.vcf*), *.vcf*", , "CHOISSISSEZ LE FICHIER A TRAITER", , False)
If NomFichier = "Faux" Then Exit Sub
ReDim T(1, 20)          ' Déclare array
Fichier = FreeFile
Open NomFichier For Input As #Fichier
Line Input #Fichier, Ligne
Close #Fichier          ' Fermeture fichier texte
' Restitution du tableau séparateur chr(10
Tablo = Split(Ligne, Chr(10))
For i = 0 To UBound(Tablo)
    On Error Resume Next
    Cells(1, i + 1) = Replace(Split(Tablo(i), ":")(1), ";", " ") ' Ligne 1 à modifier suivant besoin
Next i
End Sub

A adapter suivant votre contexte, traitement de multiples fichiers ou autre.

Bonjour, c'est parfait, juste une précision, après l'import du 1er vcf je voudrais aller sur la ligne du dessous dans excel, pour aller chercher et importer un autre vcf et ainsi de suite.

Merci beaucoup

sylvanu · 28 Juin 2024

Re,
Une possibilité simple :

VB:

Sub Import()
Dim NomFichier$, Nligne%, N%, T, Tablo, i%
FichierSuivant:
Nligne = Nligne + 1 ' ligne ecriture
NomFichier = Application.GetOpenFilename("Text files (*.vcf*), *.vcf*", , "CHOISSISSEZ LE FICHIER A TRAITER", , False)
If NomFichier = "Faux" Then Exit Sub
ReDim T(1, 20)          ' Déclare array
Fichier = FreeFile
Open NomFichier For Input As #Fichier
Line Input #Fichier, Ligne
Close #Fichier          ' Fermeture fichier texte
' Restitution du tableau séparateur chr(10
Tablo = Split(Ligne, Chr(10))
For i = 0 To UBound(Tablo)
    On Error Resume Next
    Cells(Nligne, i + 1) = Replace(Split(Tablo(i), ":")(1), ";", " ") ' Ligne 1 à modifier suivant besoin
Next i
GoTo FichierSuivant
End Sub

Il boucle sur chaque fichier. On en sort en faisant annuler dans la demande de fichiers.
Sinon si tous vos vcf sont dans le même dossier on peut tout traiter d'un seul coup, cela dépend de votre contexte.

sylvanu · 28 Juin 2024

Re,
Si toutes vos fiches vcf sont dans le même dossier, utilisez cette PJ, elle rapatrie d'un seul coup toutes vos fiches :

VB:

Public Chemin$, NomFichier$, Nligne%
Sub ImportFiles()
Dim Repertoire, Fichier
[A:L].ClearContents: Nligne = 0
Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
Repertoire.Show
If Repertoire.SelectedItems.Count > 0 Then Chemin = Repertoire.SelectedItems(1) & "\" Else Exit Sub
Fichier = Dir(Chemin)
Do While Len(Fichier) > 0   'Boucle sur tous les fichiers vcf du répertoire
    NomFichier = Chemin & Fichier
    If Right(NomFichier, 4) = ".vcf" Then
        Nligne = Nligne + 1
        Import
    End If
    Fichier = Dir()
Loop
End Sub
Sub Import()
Dim N%, T, Tablo, i%
ReDim T(1, 20)          ' Déclare array
Fichier = FreeFile
Open NomFichier For Input As #Fichier
Line Input #Fichier, Ligne
Close #Fichier          ' Fermeture fichier texte
' Restitution du tableau séparateur chr(10
Tablo = Split(Ligne, Chr(10))
For i = 0 To UBound(Tablo)
    On Error Resume Next
    Cells(Nligne, i + 1) = Replace(Split(Tablo(i), ":")(1), ";", " ") 
Next i
End Sub

alexga78 · 30 Juin 2024

Bonjour sri75, le forum,

Une autre solution via Power Query si les fichiers sont dans le même dossier.

VB:

let
    fx = (tbl) =>
         [x = Table.ToList(tbl, (x)=> List.Zip(List.RemoveNulls(List.Transform(
              Lines.FromBinary(x{0},null,null,1252),
              (x)=> if x = "" then null else Text.Split(Text.Replace(x,";"," "),":"))))),
          y =  List.Transform(x,
                (x)=> Table.FromRecords({Record.RemoveFields(Record.FromList(
                 List.Transform(x{1}, Text.Trim), x{0}), {"BEGIN","END"})}))
         ] [y],
    Source = Table.SelectRows(Folder.Files("C:\New folder"), each [Extension] = ".vcf"),
    Result = Table.Combine(fx(Source))
in
    Result

Bon dimanche.

sri75 · 1 Juillet 2024

sylvanu à dit:

Re,
Si toutes vos fiches vcf sont dans le même dossier, utilisez cette PJ, elle rapatrie d'un seul coup toutes vos fiches :

VB:

Public Chemin$, NomFichier$, Nligne%
Sub ImportFiles()
Dim Repertoire, Fichier
[A:L].ClearContents: Nligne = 0
Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
Repertoire.Show
If Repertoire.SelectedItems.Count > 0 Then Chemin = Repertoire.SelectedItems(1) & "\" Else Exit Sub
Fichier = Dir(Chemin)
Do While Len(Fichier) > 0   'Boucle sur tous les fichiers vcf du répertoire
    NomFichier = Chemin & Fichier
    If Right(NomFichier, 4) = ".vcf" Then
        Nligne = Nligne + 1
        Import
    End If
    Fichier = Dir()
Loop
End Sub
Sub Import()
Dim N%, T, Tablo, i%
ReDim T(1, 20)          ' Déclare array
Fichier = FreeFile
Open NomFichier For Input As #Fichier
Line Input #Fichier, Ligne
Close #Fichier          ' Fermeture fichier texte
' Restitution du tableau séparateur chr(10
Tablo = Split(Ligne, Chr(10))
For i = 0 To UBound(Tablo)
    On Error Resume Next
    Cells(Nligne, i + 1) = Replace(Split(Tablo(i), ":")(1), ";", " ")
Next i
End Sub

Bonjour, le boucle fonctionne bine , par contre contrairement à la première macro les noms et prénoms ne sont pas séparés, si il était possible d'avoir les noms dans une colonne et les prénoms dans une autre ce serait parfait .
Dans le fichier joint la macro qui sépare les noms et prénoms, je n'arrive pas à l'intégrer dans la votre
Merci et bonne journée

sylvanu · 1 Juillet 2024

Bonjour,

sri75 à dit:
par contre contrairement à la première macro les noms et prénoms ne sont pas séparés,

Ils ne le furent jamais ! . On avait Nom Prénom en colonne C et l'inverse en colonne D. Comme cela l'est dans le vcf.
En PJ une V4, j'ai juste rajouté à la fin de Import :

VB:

Cells(Nligne, "D") = Split(Cells(Nligne, "C"), " ")(1)
Cells(Nligne, "C") = Split(Cells(Nligne, "C"), " ")(0)

sri75 · 1 Juillet 2024

sylvanu à dit:
Bonjour,

Ils ne le furent jamais ! . On avait Nom Prénom en colonne C et l'inverse en colonne D. Comme cela l'est dans le vcf.
En PJ une V4, j'ai juste rajouté à la fin de Import :

VB:

Cells(Nligne, "D") = Split(Cells(Nligne, "C"), " ")(1) Cells(Nligne, "C") = Split(Cells(Nligne, "C"), " ")(0)

Bonjour, un grand merci c'est parfait , si je peux abuser un peu

Pour la dernière colonne adresse séparer rue cp et ville ?

3 RUE MONTALIVET 75008 PARIS

Merci beaucoup pour votre aide

sylvanu · 1 Juillet 2024

Re,
J'ai supprimé la colonne VCARD qui ne servait à rien, et j'ai rajouté à la fin :

VB:

Adresse = Split(Cells(Nligne, "H"), " ")                                        'Découpage adresse
Cells(Nligne, "J") = Adresse(UBound(Adresse))                                   'Ville
Cells(Nligne, "I") = "'" & Adresse(UBound(Adresse) - 1)                         'CodPost
NbL = Len(Adresse(UBound(Adresse))) + Len(Adresse(UBound(Adresse) - 1)) + 2     'Nbcar Ville+Codpost
Cells(Nligne, "H") = Mid(Cells(Nligne, "H"), 1, Len(Cells(Nligne, "H")) - NbL)  'Adresse

sri75 · 1 Juillet 2024

sylvanu à dit:

Re,
J'ai supprimé la colonne VCARD qui ne servait à rien, et j'ai rajouté à la fin :

VB:

Adresse = Split(Cells(Nligne, "H"), " ")                                        'Découpage adresse
Cells(Nligne, "J") = Adresse(UBound(Adresse))                                   'Ville
Cells(Nligne, "I") = "'" & Adresse(UBound(Adresse) - 1)                         'CodPost
NbL = Len(Adresse(UBound(Adresse))) + Len(Adresse(UBound(Adresse) - 1)) + 2     'Nbcar Ville+Codpost
Cells(Nligne, "H") = Mid(Cells(Nligne, "H"), 1, Len(Cells(Nligne, "H")) - NbL)  'Adresse

Bonjour, c'est exactement ce dont j'avais besoin, encore merci pour votre aide précieuse et votre patience.
Très bonne journée

XL 2010 import fichier .vcf dans excel

sri75

XLDnaute Occasionnel

Pièces jointes

wDog66

XLDnaute Occasionnel

sri75

XLDnaute Occasionnel

wDog66

XLDnaute Occasionnel

sylvanu

XLDnaute Barbatruc

Pièces jointes

sri75

XLDnaute Occasionnel

sri75

XLDnaute Occasionnel

sylvanu

XLDnaute Barbatruc

Pièces jointes

sylvanu

XLDnaute Barbatruc

Pièces jointes

alexga78

XLDnaute Occasionnel

sri75

XLDnaute Occasionnel

Pièces jointes

sylvanu

XLDnaute Barbatruc

Pièces jointes

sri75

XLDnaute Occasionnel

sylvanu

XLDnaute Barbatruc

Pièces jointes

sri75

XLDnaute Occasionnel

Discussions similaires