XL 2010 import fichier .vcf dans excel

S

sri75

XLDnaute Occasionnel
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
 

Pièces jointes

  • Laurianne_GUILLOT.vcf.txt
    218 bytes · Affichages: 14
Trier par date Trier par votes
dysorthographie

dysorthographie

XLDnaute Accro
bonjour,
j'ai envies d'y mettre mon grain de sel:cool:
VB: 
Type VCF
    Nom As String
    PNom As String
    FN As String
    TEL As String
    EMAIL As String
    ADR As String
End Type
Property Get GetFichier(Optional Filter = "*.*") As String
With CreateObject("MSComDlg.CommonDialog")
    .Filter = Filter
    .ShowOpen
   GetFichier = .Filename
End With

End Property

Property Get GetVCARD(Fichier) As String
    Dim Exist As Boolean
    With CreateObject("Scripting.FileSystemObject")
        If Not .FileExists(Fichier) Then Exit Property
        With .OpenTextFile(Fichier)
            GetVCARD = .ReadAll
            .Close
        End With
    End With
End Property

Sub test()
Dim Fichier As String, txt, Vcards() As VCF, Nb As Integer, i As Integer
Fich = GetFichier("VCARD Files (*.vcf)|*.vcf")
If Fich = "" Then Exit Sub
txt = Split(GetVCARD(Fich), "VCARD")
For i = 1 To UBound(txt) Step 2
    ReDim Preserve Vcards(Nb)
    Vcard txt(i), Vcards(Nb)
    Nb = Nb + 1
Next
For i = 0 To UBound(Vcards)
    Debug.Print Vcards(i).Nom, Vcards(i).PNom, Vcards(i).FN, Vcards(i).ADR, Vcards(i).TEL, Vcards(i).EMAIL
Next

End Sub

Sub Vcard(ByVal txt, ByRef card As VCF)
txt = Split(txt, Chr(10))
For i = 0 To UBound(txt)
    If Mid(txt(i), 1, 2) = "N:" Then
        Mid(txt(i), 1, 2) = "  "
        card.Nom = Trim(Split(txt(i), ";")(0))
        card.PNom = Trim(Split(txt(i), ";")(1))
    End If
    If Mid(txt(i), 1, 3) = "FN:" Then
        Mid(txt(i), 1, 3) = "   "
        card.FN = Trim(txt(i))
    End If
 If Mid(txt(i), 1, Len("TEL;WORK;VOICE:")) = "TEL;WORK;VOICE:" Then
        Mid(txt(i), 1, Len("TEL;WORK;VOICE:")) = Space(Len("TEL;WORK;VOICE:"))
        card.TEL = Trim(txt(i))
    End If
     If Mid(txt(i), 1, Len("EMAIL;INTERNET:")) = "EMAIL;INTERNET:" Then
        Mid(txt(i), 1, Len("EMAIL;INTERNET:")) = Space(Len("EMAIL;INTERNET:"))
        card.EMAIL = Trim(txt(i))
    End If
    If Mid(txt(i), 1, Len("ADR;TYPE=WORK:;;")) = "ADR;TYPE=WORK:;;" Then
        Mid(txt(i), 1, Len("ADR;TYPE=WORK:;;")) = Space(Len("ADR;TYPE=WORK:;;"))
        card.ADR = Trim(txt(i))
    End If

Next
End Sub
je suis parti de cette hippothèse:
Code: 
BEGIN:VCARD
VERSION:3.0
N:GUILLOT;Laurianne
FN:Laurianne GUILLOT
TEL;WORK;VOICE:+33 4 74 21 60 18
EMAIL;INTERNET:laurianne.guillot@notaires.fr
ADR;TYPE=WORK:;;11 AVENUE ALPHONSE MUSCAT 01000 BOURG-EN-BRESSE
END:VCARD

BEGIN:VCARD
VERSION:3.0
N:DUPONT;Jean
FN:Jean DUPONT
TEL;WORK;VOICE:+33 1 23 45 67 89
EMAIL;INTERNET:jean.dupont@example.com
ADR;TYPE=WORK:;;123 RUE DE LA PAIX 75002 PARIS
END:VCARD

BEGIN:VCARD
VERSION:3.0
N:DURAND;Marie
FN:Marie DURAND
TEL;WORK;VOICE:+33 2 34 56 78 90
EMAIL;INTERNET:marie.durand@example.com
ADR;TYPE=WORK:;;456 AVENUE DES CHAMPS-ÉLYSÉES 75008 PARIS
END:VCARD
 
Dernière édition:
Vote positif 0 Vote négatif
S

sri75

XLDnaute Occasionnel
dysorthographie à dit:
bonjour,
j'ai envies d'y mettre mon grain de sel:cool:
VB: 
Type VCF
    Nom As String
    PNom As String
    FN As String
    TEL As String
    EMAIL As String
    ADR As String
End Type
Property Get GetFichier(Optional Filter = "*.*") As String
With CreateObject("MSComDlg.CommonDialog")
    .Filter = Filter
    .ShowOpen
   GetFichier = .Filename
End With

End Property

Property Get GetVCARD(Fichier) As String
    Dim Exist As Boolean
    With CreateObject("Scripting.FileSystemObject")
        If Not .FileExists(Fichier) Then Exit Property
        With .OpenTextFile(Fichier)
            GetVCARD = .ReadAll
            .Close
        End With
    End With
End Property

Sub test()
Dim Fichier As String, txt, Vcards() As VCF, Nb As Integer, i As Integer
Fich = GetFichier("VCARD Files (*.vcf)|*.vcf")
If Fich = "" Then Exit Sub
txt = Split(GetVCARD(Fich), "VCARD")
For i = 1 To UBound(txt) Step 2
    ReDim Preserve Vcards(Nb)
    Vcard txt(i), Vcards(Nb)
    Nb = Nb + 1
Next
For i = 0 To UBound(Vcards)
    Debug.Print Vcards(i).Nom, Vcards(i).PNom, Vcards(i).FN, Vcards(i).ADR, Vcards(i).TEL, Vcards(i).EMAIL
Next

End Sub

Sub Vcard(ByVal txt, ByRef card As VCF)
txt = Split(txt, Chr(10))
For i = 0 To UBound(txt)
    If Mid(txt(i), 1, 2) = "N:" Then
        Mid(txt(i), 1, 2) = "  "
        card.Nom = Trim(Split(txt(i), ";")(0))
        card.PNom = Trim(Split(txt(i), ";")(1))
    End If
    If Mid(txt(i), 1, 3) = "FN:" Then
        Mid(txt(i), 1, 3) = "   "
        card.FN = Trim(txt(i))
    End If
 If Mid(txt(i), 1, Len("TEL;WORK;VOICE:")) = "TEL;WORK;VOICE:" Then
        Mid(txt(i), 1, Len("TEL;WORK;VOICE:")) = Space(Len("TEL;WORK;VOICE:"))
        card.TEL = Trim(txt(i))
    End If
     If Mid(txt(i), 1, Len("EMAIL;INTERNET:")) = "EMAIL;INTERNET:" Then
        Mid(txt(i), 1, Len("EMAIL;INTERNET:")) = Space(Len("EMAIL;INTERNET:"))
        card.EMAIL = Trim(txt(i))
    End If
    If Mid(txt(i), 1, Len("ADR;TYPE=WORK:;;")) = "ADR;TYPE=WORK:;;" Then
        Mid(txt(i), 1, Len("ADR;TYPE=WORK:;;")) = Space(Len("ADR;TYPE=WORK:;;"))
        card.ADR = Trim(txt(i))
    End If

Next
End Sub
je suis parti de cette hippothèse:
Code: 
BEGIN:VCARD
VERSION:3.0
N:GUILLOT;Laurianne
FN:Laurianne GUILLOT
TEL;WORK;VOICE:+33 4 74 21 60 18
EMAIL;INTERNET:laurianne.guillot@notaires.fr
ADR;TYPE=WORK:;;11 AVENUE ALPHONSE MUSCAT 01000 BOURG-EN-BRESSE
END:VCARD

BEGIN:VCARD
VERSION:3.0
N:DUPONT;Jean
FN:Jean DUPONT
TEL;WORK;VOICE:+33 1 23 45 67 89
EMAIL;INTERNET:jean.dupont@example.com
ADR;TYPE=WORK:;;123 RUE DE LA PAIX 75002 PARIS
END:VCARD

BEGIN:VCARD
VERSION:3.0
N:DURAND;Marie
FN:Marie DURAND
TEL;WORK;VOICE:+33 2 34 56 78 90
EMAIL;INTERNET:marie.durand@example.com
ADR;TYPE=WORK:;;456 AVENUE DES CHAMPS-ÉLYSÉES 75008 PARIS
END:VCARD
Cliquez pour agrandir...
Bonjour et merci je vais tester

sinon dans un registre plus simple, j'ai un tableau avec en colonne J adresse, cp et ville,

quelle macro faudrait il pour avoir dans des cellules separées ( idealement J, K et L les trois données ?

ex comme ca

87, bld de Dijon 10800 SAINT-JULIEN-LES-VILLAS


Merci pour votre aide

Bonne journée
 
Vote positif 0 Vote négatif
dysorthographie

dysorthographie

XLDnaute Accro
Bonjour,
VB: 
Type VCF
    Nom As String
    PNom As String
    FN As String
    TEL As String
    EMAIL As String
    ADR As String
    Cp As String
    Ville As String
End Type
Property Get GetFichier(Optional Filter = "*.*") As String
With CreateObject("MSComDlg.CommonDialog")
    .Filter = Filter
    .ShowOpen
   GetFichier = .Filename
End With

End Property

Property Get GetVCARD(Fichier) As String
    Dim Exist As Boolean
    With CreateObject("Scripting.FileSystemObject")
        If Not .FileExists(Fichier) Then Exit Property
        With .OpenTextFile(Fichier)
            GetVCARD = .ReadAll
            .Close
        End With
    End With
End Property

Sub test()
Dim Fichier As String, txt, Vcards() As VCF, Nb As Integer, I As Integer
Fich = GetFichier("VCARD Files (*.vcf)|*.vcf")
If Fich = "" Then Exit Sub
txt = Split(GetVCARD(Fich), "VCARD")
For I = 1 To UBound(txt) Step 2
    ReDim Preserve Vcards(Nb)
    Vcard txt(I), Vcards(Nb)
    Nb = Nb + 1
Next
For I = 0 To UBound(Vcards)
    Debug.Print Vcards(I).Nom, Vcards(I).PNom, Vcards(I).FN, Vcards(I).ADR, Vcards(I).Cp, Vcards(I).Ville, Vcards(I).TEL, Vcards(I).EMAIL
Next

End Sub

Sub Vcard(ByVal txt, ByRef card As VCF)
txt = Split(txt, Chr(10))
For I = 0 To UBound(txt)
    If Mid(txt(I), 1, 2) = "N:" Then
        Mid(txt(I), 1, 2) = "  "
        card.Nom = Trim(Split(txt(I), ";")(0))
        card.PNom = Trim(Split(txt(I), ";")(1))
    End If
    If Mid(txt(I), 1, 3) = "FN:" Then
        Mid(txt(I), 1, 3) = "   "
        card.FN = Trim(txt(I))
    End If
 If Mid(txt(I), 1, Len("TEL;WORK;VOICE:")) = "TEL;WORK;VOICE:" Then
        Mid(txt(I), 1, Len("TEL;WORK;VOICE:")) = Space(Len("TEL;WORK;VOICE:"))
        card.TEL = Trim(txt(I))
    End If
     If Mid(txt(I), 1, Len("EMAIL;INTERNET:")) = "EMAIL;INTERNET:" Then
        Mid(txt(I), 1, Len("EMAIL;INTERNET:")) = Space(Len("EMAIL;INTERNET:"))
        card.EMAIL = Trim(txt(I))
    End If
    If Mid(txt(I), 1, Len("ADR;TYPE=WORK:;;")) = "ADR;TYPE=WORK:;;" Then
        Mid(txt(I), 1, Len("ADR;TYPE=WORK:;;")) = Space(Len("ADR;TYPE=WORK:;;"))
        card.ADR = Trim(txt(I))
    End If

Next
EclateAdresse card
End Sub
Sub EclateAdresse(Vcard As VCF)
Dim T() As String, c As Integer, I As Integer
T() = Split(Vcard.ADR)
Vcard.ADR = ""
For I = UBound(T) To 0 Step -1
    If IsNumeric(T(I)) Then c = c + 1
    If c = 1 And Not IsNumeric(T(I)) Then c = c + 1
    Select Case c
            Case 0
                Vcard.Ville = Trim(T(I) & " " & Vcard.Ville)
            Case 1
                Vcard.Cp = Trim(T(I) & " " & Vcard.Cp)
            Case Else
            Vcard.ADR = Trim(T(I) & " " & Vcard.ADR)
    End Select
Next
End Sub
 
Vote positif 0 Vote négatif

Discussions similaires

M
  • Question
XL 2010 Impossible d'exécuter la macro. Importe Excel vers Word.
Réponses
6
Affichages
186
wDog66
wDog66
vgendron
  • Question
Power Query [Resolu] Importer plusieurs fichiers excel provenant de dossiers différents sur sharepoint
Réponses
6
Affichages
576
Staple1600
Staple1600
G
  • Question
Microsoft 365 Import Donnes issu de fichier CSV
2 3
Réponses
40
Affichages
1 K
laurent950
laurent950
J
  • Question
XL 2021 excel - vbs - csv
2
Réponses
28
Affichages
690
jerome1980
J
1
  • Question
Microsoft 365 Import de données depuis fichiers - lignes manquantes
Réponses
6
Affichages
415
1dudu9
1
M
  • Question
Microsoft 365 Importer des PDF dans Excel
Réponses
8
Affichages
528
patricktoulon
patricktoulon
B
  • Résolu(e)
XL 2021 Calendrier @patricktoulon
Réponses
5
Affichages
317
patricktoulon
patricktoulon
V
  • Question
Microsoft 365 Fichier CSV en EXCEL
Réponses
8
Affichages
385
patricktoulon
patricktoulon
C
  • Question
XL 2019 cookie dans navigateur web Excel
Réponses
2
Affichages
150
C.Laurent
C
T
  • Question
XL 2013 Besoin d'aide : Création d'un graphique chronologique dans Excel
Réponses
3
Affichages
205
sylvanu
sylvanu

Membres actuellement en ligne

6 membres et 68 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
313 092
Messages
2 095 188
Membres
106 205
dernier inscrit
سي بلقاسم