excelden metin belgesi.txt aktarma

[mehmet2285]

Merhabalar,
benim sorum excelden metin belgesi.txt aktarma ile ilgili



a10:h70 arasında kalan bölgeyi ekleyecegim bir düğme ile
"b1" hücresinin içini isim alarak, metin belgesi.txt şeklinde kaydedilmesi.
daha önce yapılmış örnekler vardı forumda ama arşiv silindiğinden açamadım onun için buraya yazdım.

hocamlarımdan yardım istiyorum, fazla kod yazma bilgim yok
deneme yanılma , sagdan soldan alarak kendi işlerim için dosyalar oluşturuyorum
şimdiden teşekür ederim ...

 

[Orion1]

Dosyanız ektedir.

Sub txt_kayit()
Dim deg As String, i As Integer
If Range("B1").Value = "" Then
    MsgBox "B1 hücresi boş." & vbLf & _
    "Dosyaya isim verebilmek için B1 hücresine bir ad yazınız.", vbCritical, "UYAR"
    Exit Sub
End If
Open (ThisWorkbook.Path & "\" & Range("B1").Value & ".txt") For Append As #1
For i = 10 To 70
    For k = 1 To 7
        deg = deg & " " & Cells(i, k).Value
    Next k
    Write #1, Right(deg, Len(deg) - 1)
    deg = ""
Next i
Close #1
MsgBox "Dosyanızın bulunduğu klasöre " & Range("B1").Value & _
" İsminde txt dosyası oluşturuldu." & vbLf & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
    
End Sub

 

[mehmet2285]

her zamanki gibi süpersiniz saygılarımla birlikte teşekkürlerimi de sunarım efendim..
Allah yardımcınız olsun kolay gelsin...

 

[Orion1]

her zamanki gibi süpersiniz saygılarımla birlikte teşekkürlerimi de sunarım efendim..
Allah yardımcınız olsun kolay gelsin...

Rica ederim.
İyiçalışmalar.

 

[Orion1]

Buda başka bir metodla ,yeni metodla yazmak.
referanslardan microsoft scripting runtime seçili olmalı.

Sub test()
Dim fso As Object, f
If Range("B1").Value = "" Then
    MsgBox "B1 hücresi boş." & vbLf & _
    "Dosyaya isim verebilmek için B1 hücresine bir ad yazınız.", vbCritical, "UYAR"
    Exit Sub
End If

Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(ThisWorkbook.Path & "\" & Range("B1").Value & ".txt", ForAppending, True)
For i = 10 To 70
    For k = 1 To 7
        deg = deg & " " & Cells(i, k).Value
    Next k
   f.WriteLine Right(deg, Len(deg) - 1)
    deg = ""
Next
MsgBox "Dosyanızın bulunduğu klasöre " & Range("B1").Value & _
" İsminde txt dosyası oluşturuldu." & vbLf & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub