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: 16
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
371
wDog66
wDog66
G
  • Résolu(e)
XL 2016 Mise en forme d'un export de logiciel dans un fichier Excel
2 3
Réponses
30
Affichages
836
Gils92
G
vgendron
  • Question
Power Query [Resolu] Importer plusieurs fichiers excel provenant de dossiers différents sur sharepoint
Réponses
6
Affichages
1 K
Staple1600
Staple1600
P
  • Résolu(e)
XL 2013 creation d'une arborescence
2 3
Réponses
30
Affichages
746
psgm76
P
G
  • Question
Microsoft 365 Import Donnes issu de fichier CSV
2 3
Réponses
40
Affichages
2 K
laurent950
laurent950
edgy63
  • Question
Microsoft 365 Remplir cellules à partir de plusieurs fichiers Excel d'un dossier
2
Réponses
17
Affichages
500
alexga78
A
F
  • Résolu(e)
XL 2021 VBA et Power Query : ecrire des requetes avec variables
2
Réponses
28
Affichages
1 K
Florent74
F
P
  • Résolu(e)
XL 2010 Formule excel synthese arrets
Réponses
2
Affichages
255
pomunho
P
kkamadou
  • Question
importation de donnees dans un fichier excel dans un formulaire
Réponses
3
Affichages
424
kkamadou
kkamadou
J
  • Question
XL 2021 excel - vbs - csv
2
Réponses
28
Affichages
1 K
jerome1980
J

Membres actuellement en ligne

6 membres et 111 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
315 089
Messages
2 116 099
Membres
112 661
dernier inscrit
ceucri