- Katılım
- 9 Ocak 2019
- Mesajlar
- 33
- Excel Vers. ve Dili
- 2010 türkçe
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Güzel kod, yazanın ellerine sağlık...Sub Test4()
'Haluk - 23/01/2019
'E-POsta: sa4truss@gmail.com
'
Dim objShell As Object, objStream As Object
Dim strDesktop As String, i As Long, NoA As Long
Dim Name As Variant, myStr As String, lastName As String, firstName As String
Const adSaveCreateOverWrite = 2
Set objShell = CreateObject("Wscript.Shell")
strDesktop = objShell.SpecialFolders("Desktop")
NoA = Range("A" & Rows.Count).End(xlUp).Row
Set objStream = CreateObject("ADODB.Stream")
objStream.Charset = "windows-1254"
objStream.Open
For i = 2 To NoA
Name = Split(Trim(Range("A" & i).Text), " ")
lastName = Name(UBound(Name))
firstName = Trim(Replace(Range("A" & i).Text, lastName, ""))
myStr = "BEGIN:VCARD" & vbCrLf
myStr = myStr & "VERSION:3.0" & vbCrLf
myStr = myStr & "N;CHARSET=windows-1254;ENCODING=QUOTED-PRINTABLE:" & lastName & ";" & firstName & ";;;" & vbCrLf
myStr = myStr & "FN;CHARSET=windows-1254;ENCODING=QUOTED-PRINTABLE:" & Range("A" & i) & vbCrLf
myStr = myStr & "TEL;type=CELL;type=VOICE;type=pref:" & Range("B" & i) & vbCrLf
myStr = myStr & "TEL;type=HOME;type=VOICE:" & Range("C" & i) & vbCrLf
myStr = myStr & "EMAIL;TYPE=HOME,TYPE=pref;TYPE=INTERNET:" & Range("D" & i) & vbCrLf
myStr = myStr & "END:VCARD" & vbCrLf
objStream.WriteText myStr
Name = ""
Next
objStream.SaveToFile strDesktop & "\myVcard.vcf", adSaveCreateOverWrite
objStream.Close
Set objStream = Nothing
Set objShell = Nothing
End Sub
Yada bu kodları kullanın tercih sizin excelde çalışma sayfanıza buton ekleyip