.csv formatına çevirmek?

[halit3]

kod:

Sub txt_veri_al()


Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

say = fL.GetFolder(ThisWorkbook.Path).Files.Count

dosyaadi = ThisWorkbook.Path & "\OutlookContacts " & say & ".csv"
Open dosyaadi For Output As #1

Print #1, Cells(1, 1).Value

For a = 2 To [a65536].End(3).Row
Print #1, ",,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,""" & Cells(a, 1) & """,""SMTP"",,,,,,,"
Next

Close #1
MsgBox "Bitti", vbInformation, "Bilgi"


End Sub

 

[halit3]

dosya not defteri (metin belgesinden yapılmıştır) yani txt uzantılı dosyaya kopyala yapıştır ile yapılarak uzantısı csv olarak değiştirilmiştir.

 

[ÖmerBey]

Aşağıdaki linkten aldığım kodu dosyanıza uyarladım.
http://www.excel.web.tr/f14/csv-cevirme-t62481.html
Görüntüde isteğinizden farklı oluyor ama denediğim kadarıyla işe yarıyor.
Siz de deneyiniz...
Harici Link: http://www.dosya.tc/server31/4UyoRl/OutlookContacts.rar.html

 

[halit3]

10 nolu mesajımda bu dosyanın metin (not defteri txt uzantılı )dosyası olduğunu yazmıştım.

Sayın mucit77 de 23 nolu mesajda dosyayı metin dosyası olarak kayıt yaptırıyor ve uzantısını csv olarak değiştiriyor.


Linkdeki dosyayı indirin Sayfa1 deki birinci satırda başlıklar var ve düğmelere sırası ile tıklayın.

aktar düğmesine tıklamadan önce gerekli eklemeleride yapabilirsiniz.

son olarak kod çevirdiği dosyayı açıyor.


kod:

Sub txt_veri_al()

Dosya = Application.GetOpenFilename("Tüm Dosyalar(*.*), *.*," & _
"Text Files (*.txt), *.txt, " & _
"Excel Files(*.xls;*.xlsx;*.xlsm;*.xla;*.xlam),*.xls;*.xlsx;*.xlsm;*.xla;*.xlam," & _
"Add-in Files (*.xl*), *.xl*, " & _
"Picture Files (*.gif;*.jpg;*.jpeg;*.bmp),*.gif;*.jpg;*.jpeg;*.bmp")
       
If Dosya = False Then
MsgBox "Dosya seçme işlemini yapmadınız.", vbInformation, "DİKKAT"
Exit Sub
Else
End If

[COLOR="Red"]aranan = ","
adres = Replace(Cells(1, 1), """", "") & aranan
deg1 = Split(adres, aranan)
If UBound(deg1) > 0 Then
For j = 0 To Val(UBound(deg1)) - 1
Cells(1, j + 1).Value = deg1(j)
Next
End If[/COLOR]

sat1 = 2
Open Dosya For Input As #1

Do While Not EOF(1)
Line Input #1, veri
Cells(sat1, 48).Value = veri
Cells(sat1, 49).Value = "SMTP"
sat1 = sat1 + 1
Loop

Close #1

MsgBox "Bitti", vbInformation, "Bilgi"

End Sub

Sub Aktar()

sat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sut = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

say = fL.GetFolder(ThisWorkbook.Path).Files.Count

dosyaadi = ThisWorkbook.Path & "\OutlookContacts " & say & ".csv"
Open dosyaadi For Output As #1

deg2 = ","""""
deg3 = ","""
deg4 = """"

For i = 1 To sat
deg1 = ""
For j = 1 To sut
If Cells(i, j).Value = "" Then
deg1 = deg1 & deg2
Else
deg1 = deg1 & deg3 & Cells(i, j).Value & deg4
End If
Next j
Print #1, Mid(deg1, 2, Len(deg1))
Next i
Close #1


If dosyaadi <> "" Then
CreateObject("Shell.Application").Open (dosyaadi)
End If

MsgBox "Bitti", vbInformation, "Bilgi"
End Sub

hesap.txt dosyasındaki değer

deneme@hotmail.com
test@hotmail.com

 

[halit3]

Sayın alican60 tamam ekledim ilgili mesajınızdaki resimi silin.

 

[efekentli46]

1 nolu mesajınıza göre şimdi farklı söylüyorsunuz.
yinede neresi olmuyor anlamıyorum.
göndermiş olduğunuz hesap.txt dosyasını siz cvs dosyasına dönüştürün ve buraya ekleyinki ne yapmak istediğinizi anlıyalım.

Diğer yardımcı olan sayın *mucit77* kodu excel sayfasındaki değerleri csv yapıyor.

eğer siz excel sayfasını csv yapmak istiyorsanız bu sayfaya ait kendi excel dosyanızı ekliyin ve istemiş olduğunuz csv dosyasınıda ekleyin bakalım.

aslında aynı şeyleri söylüyoruz. ama birbirimizi anlıyamıyoruz.

bu kod sayfadaki değerleri csv yapıyor.

hocam ben aynı şeyleri söylüyorum hep ama programlama kafasında söyleyemiyorum. hesap.txt dosyasını csv dönüştürüp ekleyin diyorsunuz ya, ilk mesajımda ve diğer mesajlarımda verdiğim orjinal hotmail csv hali işte o istediğiniz dosya, yani bizim ulaşmak istediğimiz dosya.

http://www.dosya.tc/server31/0D3fMw/OutlookContacts.rar.html (hesap.txtyi bu hale döndürmek istedik)

 

[efekentli46]

10 nolu mesajımda bu dosyanın metin (not defteri txt uzantılı )dosyası olduğunu yazmıştım.

Sayın mucit77 de 23 nolu mesajda dosyayı metin dosyası olarak kayıt yaptırıyor ve uzantısını csv olarak değiştiriyor.

dosyayi indir


Linkdeki dosyayı indirin Sayfa1 deki birinci satırda başlıklar var ve düğmelere sırası ile tıklayın.

aktar düğmesine tıklamadan önce gerekli eklemeleride yapabilirsiniz.

son olarak kod çevirdiği dosyayı açıyor.


kod:

Sub txt_veri_al()

Dosya = Application.GetOpenFilename("Tüm Dosyalar(*.*), *.*," & _
"Text Files (*.txt), *.txt, " & _
"Excel Files(*.xls;*.xlsx;*.xlsm;*.xla;*.xlam),*.xls;*.xlsx;*.xlsm;*.xla;*.xlam," & _
"Add-in Files (*.xl*), *.xl*, " & _
"Picture Files (*.gif;*.jpg;*.jpeg;*.bmp),*.gif;*.jpg;*.jpeg;*.bmp")
       
If Dosya = False Then
MsgBox "Dosya seçme işlemini yapmadınız.", vbInformation, "DİKKAT"
Exit Sub
Else
End If

sat1 = 2
Open Dosya For Input As #1

Do While Not EOF(1)
Line Input #1, veri
Cells(sat1, 48).Value = veri
Cells(sat1, 49).Value = "SMTP"
sat1 = sat1 + 1
Loop

Close #1

MsgBox "Bitti", vbInformation, "Bilgi"

End Sub

Sub Aktar()

sat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sut = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

say = fL.GetFolder(ThisWorkbook.Path).Files.Count

dosyaadi = ThisWorkbook.Path & "\OutlookContacts " & say & ".csv"
Open dosyaadi For Output As #1

deg2 = ","""""
deg3 = ","""
deg4 = """"

For i = 1 To sat
deg1 = ""
For j = 1 To sut
If Cells(i, j).Value = "" Then
deg1 = deg1 & deg2
Else
deg1 = deg1 & deg3 & Cells(i, j).Value & deg4
End If
Next j
Print #1, Mid(deg1, 2, Len(deg1))
Next i
Close #1


If dosyaadi <> "" Then
CreateObject("Shell.Application").Open (dosyaadi)
End If

MsgBox "Bitti", vbInformation, "Bilgi"
End Sub

hesap.txt dosyasındaki değer

Bu haliyle oldu hocam, denedim çalıştı. Çok çok teşekkürler o kadar zahmet verdim, elinize sağlık.

 

[efekentli46]

Aşağıdaki linkten aldığım kodu dosyanıza uyarladım.
http://www.excel.web.tr/f14/csv-cevirme-t62481.html
Görüntüde isteğinizden farklı oluyor ama denediğim kadarıyla işe yarıyor.
Siz de deneyiniz...
Harici Link: http://www.dosya.tc/server31/4UyoRl/OutlookContacts.rar.html

görünüşte farklılık var ama denedim ve hotmail kabul etti. elimde 2 farklı kod olmuş oldu aynı şeyi yapan. ben istedim bir göz allah verdi iki göz Size de çok zahmet verdim hocam, elinize sağlık. teşekkürler

 

[halit3]

Bu haliyle oldu hocam, denedim çalıştı. Çok çok teşekkürler o kadar zahmet verdim, elinize sağlık.

24 nolu mesaja kırmızı bölümü ekledim eğer A1 hücesindeki başlıklar bir bütün ise kod onları diğer sutünlara aktararak ayırıyor

İyi çalışmalar.

 

[efekentli46]

24 nolu mesaja kırmızı bölümü ekledim eğer A1 hücesindeki başlıklar bir bütün ise kod onları diğer sutünlara aktararak ayırıyor

İyi çalışmalar.

teşekkürler hocam, size de iyi çalışmalar

 

[htsumer]

Buna benzer bir konu açmıştım ama burdan devam etmek istedim.

Benim csv formatım farklı kodlarda buna ait bir kodlama yaparmısınız..
Bu yandex vcard formatı

Excelde mail adreslerim var. Bu maillere göre bu formatta csv dosyası oluşturulması

Yani son hali bu şekil olacak,(uzantıları yanlış yazmışım yeni1-yeni2 şeklinde devam edecek)