Excel vers VCF

Bonjour

J'ai crée une macro qui permet de creer une fiche contact en vcf a partir d'excel

voici le code qui permet ceci

Sub Bouton1_Cliquer()

' CSV fields are in this order:
' Title (Dr. etc), First, Middle, Last, Suffix, Company, Job Title, email1,
' telwork, telhome, telcell, telfax,
' Work Street, Work city, Work State, Work Zip, Work Country
' Home Street, Home City, Home State, Home Zip, Home Country
' Default Mailing Address - Valid entry is 1 (Home) 2 (Work)
' URL, IM, bday, Note, email2, email3

    Dim FileNum As Integer
    Dim iRow As Double
    iRow = 2
    FileNum = FreeFile

    'Loop through rows and create a vcard
    'until the first name field is empty
    While VBA.Trim(Sheets("Feuil1").Cells(iRow, 2)) <> ""

     fName = VBA.Trim(Sheets("Feuil1").Cells(iRow, 2))
     lName = VBA.Trim(Sheets("Feuil1").Cells(iRow, 4))

    OutFilePath = ThisWorkbook.Path & "\" & fName & " " & lName & ".vcf"
    Open OutFilePath For Output As FileNum

 nTitle = VBA.Trim(Sheets("Feuil1").Cells(iRow, 1))
 mName = VBA.Trim(Sheets("Feuil1").Cells(iRow, 3))
 nSuffix = VBA.Trim(Sheets("Feuil1").Cells(iRow, 5))
 Company = VBA.Trim(Sheets("Feuil1").Cells(iRow, 6))
 jobTitle = VBA.Trim(Sheets("Feuil1").Cells(iRow, 7))
 email1 = VBA.Trim(Sheets("Feuil1").Cells(iRow, 8))
 telWork = VBA.Trim(Sheets("Feuil1").Cells(iRow, 9))
 telHome = VBA.Trim(Sheets("Feuil1").Cells(iRow, 10))
 telCell = VBA.Trim(Sheets("Feuil1").Cells(iRow, 11))
 telFax = VBA.Trim(Sheets("Feuil1").Cells(iRow, 12))
 AddrWorkStr = VBA.Trim(Sheets("Feuil1").Cells(iRow, 13))
 AddrWorkCity = VBA.Trim(Sheets("Feuil1").Cells(iRow, 14))
 AddrWorkState = VBA.Trim(Sheets("Feuil1").Cells(iRow, 15))
 AddrWorkZip = VBA.Trim(Sheets("Feuil1").Cells(iRow, 16))
 AddrWorkCountry = VBA.Trim(Sheets("Feuil1").Cells(iRow, 17))
 AddrHomeStr = VBA.Trim(Sheets("Feuil1").Cells(iRow, 18))
 AddrHomeCity = VBA.Trim(Sheets("Feuil1").Cells(iRow, 19))
 AddrHomeState = VBA.Trim(Sheets("Feuil1").Cells(iRow, 20))
 AddrHomeZip = VBA.Trim(Sheets("Feuil1").Cells(iRow, 21))
 AddrHomeCountry = VBA.Trim(Sheets("Feuil1").Cells(iRow, 22))
 defaultAddr = VBA.Trim(Sheets("Feuil1").Cells(iRow, 23))
 URL = VBA.Trim(Sheets("Feuil1").Cells(iRow, 24))
 IM = VBA.Trim(Sheets("Feuil1").Cells(iRow, 25))
 BDAY = VBA.Trim(Sheets("Feuil1").Cells(iRow, 26))
 NOTE = VBA.Trim(Sheets("Feuil1").Cells(iRow, 27))
 email2 = VBA.Trim(Sheets("Feuil1").Cells(iRow, 28))
 email3 = VBA.Trim(Sheets("Feuil1").Cells(iRow, 29))

        Print #FileNum, "BEGIN:VCARD"
        Print #FileNum, "VERSION:3.0"
        Print #FileNum, "N:" & lName & ";" & fName & ";" & mName & ";" & nTitle & ";" & nSuffix
        Print #FileNum, "FN:" & nTitle & " " & fName & " " & mName & " " & lName & " " & nSuffix
        Print #FileNum, "ORG:" & Company
        Print #FileNum, "TITLE:" & jobTitle
        Print #FileNum, "TEL;WORK;VOICE:" & telWork
        Print #FileNum, "TEL;HOME;VOICE:" & telHome
        Print #FileNum, "TEL;CELL;VOICE:" & telCell
        Print #FileNum, "TEL;WORK;FAX:" & telFax
        Print #FileNum, "ADR;WORK;PREF:;;" & AddrWorkStr & ";" & AddrWorkCity & ";" & AddrWorkState & ";" & AddrWorkZip & ";" & AddrWorkCountry
        Print #FileNum, "ADR;Home:;;" & AddrHomeStr & ";" & AddrHomeCity & ";" & AddrHomeState & ";" & AddrHomeZip & ";" & AddrHomeCountry
        Print #FileNum, "X-MS-OL-DEFAULT-POSTAL-ADDRESS:" & defaultAddr
        Print #FileNum, "URL;WORK:" & URL
        Print #FileNum, "X-MS-IMADDRESS:" & IM
        Print #FileNum, "Note:" & NOTE
        Print #FileNum, "BDAY:" & BDAY
        Print #FileNum, "EMAIL;PREF;INTERNET:" & email1
        Print #FileNum, "EMAIL;INTERNET:" & email2
        Print #FileNum, "EMAIL;INTERNET:" & email3

        Print #FileNum, "END:VCARD"

    'Close the File

    Close #FileNum
 iRow = iRow + 1

    Wend

    MsgBox iRow - 2 & " Contacts Converted."
End Sub

Le probleme c'est que ca cree un vcf par contact alors que je voudrais UN seul et unique fichier vcf contenant tout les contact.

Voili voilou

Avez vous une solution en reserve S.V.P

Merci d'avance les copains

Bonjour

Nom du fichier VCF modifié

Déplacement d'instruction en dehors de la boucle

Je t'ai laissé l'original de la macro pour comparer

A tester

Bonsoir

Merci de ta reponse ca fonctionne au petit soin

Cordialement

EulVedette