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

sylvanu · 1 Juillet 2024

Re,
Impeccable.
Mais supprimez ce vert qui porte à confusion. Il est mis pour orienter le futur lecteur directement vers la bonne solution. Donc soit la bonne solution, soit rien, c'est plus clair.

dysorthographie · 3 Juillet 2024

bonjour,
j'ai envies d'y mettre mon grain de sel

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

sri75 · 4 Juillet 2024

dysorthographie à dit:

bonjour,
j'ai envies d'y mettre mon grain de sel

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

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

dysorthographie · 4 Juillet 2024

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

XL 2010 import fichier .vcf dans excel

sri75

XLDnaute Occasionnel

Pièces jointes

sylvanu

XLDnaute Barbatruc

dysorthographie

XLDnaute Accro

sri75

XLDnaute Occasionnel

dysorthographie

XLDnaute Accro

Discussions similaires