• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

.csv formatına çevirmek?

kod:

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
 

Ekli dosyalar

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.
 

Ekli dosyalar

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:

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

Kod: 
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
Genişletmek için tıkla ...
 

Ekli dosyalar

Sayın alican60 tamam ekledim ilgili mesajınızdaki resimi silin.
 
halit3' Alıntı:
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.
Genişletmek için tıkla ...

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)
 
halit3' Alıntı:
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:

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

Kod: 
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
Genişletmek için tıkla ...

Bu haliyle oldu hocam, denedim çalıştı. Çok çok teşekkürler o kadar zahmet verdim, elinize sağlık.
 
mucit77' Alıntı:
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
Genişletmek için tıkla ...

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
 
efekentli46' Alıntı:
Bu haliyle oldu hocam, denedim çalıştı. Çok çok teşekkürler o kadar zahmet verdim, elinize sağlık.
Genişletmek için tıkla ...

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.
 
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ı

1652467304823-png.236496


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

1652467378513-png.236497


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

1652467826293-png.236498
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst