Exceldeki Rehberi Ayrı Ayrı Vcf Dosyası Yapma

[hakki83]

Merhaba Hocalarımız

Telefonuma ait (tüm kişilerin içinde olduğu) bir Vcf dosyası yedeğim var.

Bu dosyadaki A'dan Z'ye tüm kişileri, ayrı ayrı (tek tek) Vcf dosyası oluşturabilecek şekilde bir makro kodu oluşturabilir miyiz?

...........

Aynı soruyu şöyle de sorayım:

Bir Excel dosyasında, kişilerin adları (A2 satırından itibaren ayrı ayrı sütunlarda alt alta yazılı)

Cemil Çaykahveseveroğlu 05421234567
Kamil Çayiçmezoğlu 05427654321

bu şekilde kayıtlı

Bu dosyadaki kişileri, tek tek Vcf dosyası haline getirecek makro kodu oluşturabilir miyiz?

İkinci soru için benzer iki örnek dosya ektedir.

.........
(Tüm yöntemler işimi görür, yeter ki ayrı ayrı Vcf dosyalar oluşsun)
........

İhtiyacım şundandır;
tüm rehberimi başka bir ikinci telefona aktarmam gerekiyor, fakat ikinci telefona rehber, ancak tek tek Vcf dosyaları halinde atılabiliyor.


(Sitede Vcf Card, Vcf dosyası olarak arama yaptım, sonuca ulaşamadım.)

 

[Korhan Ayhan]

Merhaba,

Linklerin faydası olabilir.

Google Search

 

[Asri]

@Murat OSMA , hastag kodları üzerinden bir kaç değişiklik ile vcf den verileri okuyup ayrı ayrı vcf dosyaları oluşturur.
Her BEGIN:VCARD satırı gördüğünden yeni dosya oluştur koşulu ile oluşuyor.

'@Murat Osma, Hastag sayfa gönderim sayıları
Dim GonderiSayisi, satir
Sub HashtagSayfaGonderiSayilari()

    Dim DosyaAdi As String
    Dim DosyaYolu As String
    Dim DosyaTamAdi As String
    Dim DosyaIcerik As String
    Dim Satirlar() As String
    Dim hashtag As Variant
   
    ' Hashtag verilerinin bulunduğu dosyanın tam yolunu ve adını belirtin
    DosyaYolu = ThisWorkbook.Path & "\" ' Dosya yolunu güncelleyin
    DosyaAdi = "rehberiniz.vcf" ' Dosya adını güncelleyin
    DosyaTamAdi = DosyaYolu & DosyaAdi
    
    cikisdosya = DosyaYolu & "1.vcf"
   
    ' Dosyanın var olup olmadığını kontrol edin
    If Dir(DosyaTamAdi) = "" Then
        MsgBox DosyaAdi & " dosyası bulunamadı!"
        Exit Sub
    End If
   
    ' Dosyanın içeriğini oku
    Open DosyaTamAdi For Input As #1
    DosyaIcerik = Input$(LOF(1), #1)
    Close #1
   
    ' Satırları diziye aktar
    Satirlar = Split(DosyaIcerik, vbCrLf)
   
    ' Verileri Excel'e yazdır
    
    satir = 0
    For Each hashtag In Satirlar
        ' Hashtag verisi boş değilse işleme devam et
        
        If Trim(hashtag) = "BEGIN:VCARD" Then
           If satir <> 0 Then Close #2
           satir = satir + 1
           cikisdosya = DosyaYolu & satir & ".vcf"
           Open cikisdosya For Output As #2
           Print #2, hashtag
        Else
          Print #2, hashtag
        End If
        
    Next hashtag
   Close #2
    MsgBox "Islem tamamlandi!"
   
End Sub

 

[hakki83]

Asri hocam sağ olunuz. Bilgisayara geçince hemen bakacağım.