Telefon Rehberini Excele Aktarma

[hakki83]

Merhaba Excel Hocalarımız,

Telefon rehberini not defteriyle açınca, örnek dosyadaki gibi bir görünüşle karşılaşırız.

BEGIN:VCARD
VERSION:3.0
PRODID:-//Apple Inc.//iPhone OS 15.7.2//EN
SOYAD AD
AD SOYAD
TELEFON NUMARASI
END:VCARD

Ya da böyle

BEGIN:VCARD
VERSION:3.0
PRODID:-//Apple Inc.//iPhone OS 15.7.2//EN
SOYAD AD
AD SOYAD
TELEFON NUMARASI
TELEFON NUMARASI
TELEFON NUMARASI
END:VCARD



Yani bir kişinin bilgileri
BEGIN:VCARD hücresi ile
END:VCARD ile hücresi arasındadır.
Yani kişi kartının başı ve sonu bu iki satır oluyor.
Tüm rehber bu şekilde devam ediyor.

Burada döngüyü, yani kişilerin satır sayısını farklılaştıran şey ise, örnek dosyada görüldüğü gibi telefon numaralarının bir veya birden fazla oluşudur.

Talebim şudur:

Beşinci satırdaki hücreyi C sütununa,
End hücresine kadar olan hücreleri de yanındaki sütuna,
Sayfa1'deki gibi aktaracak kodları oluşturabilir miyiz?
Bir de eğer çok uğraştırmayacaksa ayrıca Sayfa2'deki gibi de yapabilir miyiz?
Yani hem Sayfa1'i, hem de Sayfa2'yi ikisini de.
İkisi de işe yarayabilir.

Bu dosya birçok kullanıcının işine yarayacaktır diye tahmin ediyorum.

(Kırmızı rengi sadece dikkat çeksin diye yaptım. Hiçbir biçimlendirme
ye ihtiyaç yoktur)

Teşekkürler hocalarımız.

 

[dEdE]

Merhaba,
Aşağıdaki kodu örnek dosyanızda dener misiniz?

Sub Test()
ss = Cells(Rows.Count, "A").End(3).Row
Set c = Cells.Find("BEGIN:VCARD", , xlValues, xlWhole)
If Not c Is Nothing Then
    adres = c.Address
    Do
        For i = c.Row + 4 To ss
            If Cells(i, 1) = "END:VCARD" Then Exit For
            Cells(i, 3) = Cells(i, 1)
        Next i
        Set c = Cells.FindNext(c)
    Loop While Not c Is Nothing And c.Address <> adres
End If
End Sub

 

[hakki83]

Dede hocam emeğinize bilginize sağlık.
Sayfa2 için olanı kusursuz olmuştur. Sağ olunuz.

 

[dEdE]

Sayfa2 için olanı kusursuz olmuştur.

İstenirse üçük bir değişiklikle sayfa1 için de yapılabilir. Tercihiniz Sayfa2 içindi.

 

[hakki83]

İstenirse üçük bir değişiklikle sayfa1 için de yapılabilir. Tercihiniz Sayfa2 içindi.

Olur hocam, diğerini de denemek isterim. (Sayfa1 için olanı da)

 

[dEdE]

Dener misiniz?

Sub Test()
ss = Cells(Rows.Count, "A").End(3).Row
Set c = Cells.Find("BEGIN:VCARD", , xlValues, xlWhole)
If Not c Is Nothing Then
    adres = c.Address
    Do
        sut = 3
        For i = c.Row + 4 To ss
            If Cells(i, 1) = "END:VCARD" Then Exit For
            Cells(c.Row + 4, sut) = Cells(i, 1)
            sut = sut + 1
        Next i
        Set c = Cells.FindNext(c)
    Loop While Not c Is Nothing And c.Address <> adres
End If
End Sub

 

[hakki83]

Dede hocam teşekkür ederim, ikisi içinde oluşturmuş olduğunuz kodlar tam olarak tarif ettiğim gibiydi.

Telefonların aplikasyon indirme yerlerinde; rehberi not defteri gibi yedekleyecek uygulamalar mevcuttur.


Telefon rehberini yedekleyip, tek dosya olarak bilgisayara gönderen kullanıcılar, bu kodlar ile rehberlerini daha rahat görüp inceleyebilecekler.