TXT oluşturma

[spiderman061]

Arkadaşlar tüm sayfaklardaki c sutunundaki verileri yine o sayfaların isminlerinde txt olarak kaydetmek istiyorum. bir haftadır uğraşıyorum yapamadım. lütfen birisi yardım etsin.

 

[PLİNT]

Merhaba
Şöyle deneyin
https://www.dosyaupload.com/bh55

Sub kod()
Dim a As Long, x As Long, b As Long, dosya as string
For a = 1 To ThisWorkbook.Worksheets.Count
x = Sheets(a).Cells(Rows.Count, "C").End(3).Row
dosya = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Sheets(a).Name & ".txt"
Open dosya For Output As #1
For b = 1 To x
    Print #1, Sheets(a).Cells(b, "C")
    Next
Close #1
Next
End Sub

 

[EmrExcel16]

Alternatif..

Sub Test()
    Dim Dsy, Syf, son
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    Set Dsy = Application.Workbooks.Add
    For Syf = 1 To ThisWorkbook.Sheets.Count
        son = ThisWorkbook.Sheets(Syf).Cells(Rows.Count, 3).End(3).Row
        Dsy.Worksheets(1).Range("A1:A" & son).Value = ThisWorkbook.Sheets(Syf).Range("C1:C" & son).Value
        Dsy.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & ThisWorkbook.Sheets(Syf).Name, FileFormat:=xlText
        Dsy.Worksheets(1).Range("A1:A" & son).ClearContents
    Next
    Dsy.Close False
    Application.DisplayAlerts = True: Application.ScreenUpdating = True
    MsgBox "Islem tamam.."
End Sub

 

[spiderman061]

1 hafta uğraştım ama çözemedim. sizin formul halletti. çok teşekkür ediyorum. iyi ki varsınız

 

[spiderman061]

Hocam bu formül HAM_TXT sayfasındaki verileri a sutundaki verilere göre sayfalar oluşturarak ayırıyor. Ben sadece A,B,C sutunlarındaki verileri ayırsın ve A-B sutunundaki veriler yer değiştirsin istiyorum. kısaca A-B-C sutunlarını B-A-C olarak sayfalara dağıtsın istiyorum. (ilk satırı almasın) yardımcı olabilirseniz çok memnun olurum.
Sub VERIAYIR()
Dim xSht As Worksheet
Dim xNSht As Worksheet
Dim I As Long
Dim xTRrow As Integer
Dim xCol As New Collection
Dim xTitle As String
Dim xSUpdate As Boolean
Set xSht = Sheets("HAM_TXT")
On Error Resume Next
xRCount = xSht.Cells(xSht.Rows.Count, 1).End(xlUp).Row
xTitle = "A:A"
xTRrow = xSht.Range(xTitle).Cells(1).Row
For I = 1 To xRCount
Call xCol.Add(xSht.Cells(I, 1).Text, xSht.Cells(I, 1).Text)
Next
xSUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For I = 2 To xCol.Count
Call xSht.Range(xTitle).AutoFilter(1, CStr(xCol.Item(I)))
Set xNSht = Nothing
Set xNSht = Worksheets(CStr(xCol.Item(I)))
If xNSht Is Nothing Then
Set xNSht = Worksheets.Add(, Sheets(Sheets.Count))
xNSht.Name = CStr(xCol.Item(I))
Else
xNSht.Move , Sheets(Sheets.Count)
End If
xSht.Range("A" & xTRrow & ":A" & xRCount).EntireRow.Copy xNSht.Range("A1")
xNSht.Columns.AutoFit
Next
xSht.AutoFilterMode = False
xSht.Activate
Application.ScreenUpdating = xSUpdate
End Sub

 

[EmrExcel16]

Merhaba, konu başlığinizda belirttiğiniz sorununuz çözüldü ise , yeni sorularınızı konu içeriğinin bozulmaması adına forum üzerinde yeni bir konu açarak sorunuz.

 

[spiderman061]

sorunum çözüldü çok teşekkür ediyorum

 

[spiderman061]

hocam masaüstü değilde C:\TXT klasörüne oluştursun istiyorum. nasıl değiştirebilirim

Dsy.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & ThisWorkbook.Sheets(Syf).Name, FileFormat:=xlText

 

[EmrExcel16]

Şu şekilde deneyiniz..

Dsy.SaveAs Filename:="C:\TXT\" & ThisWorkbook.Sheets(Syf).Name, FileFormat:=xlText

 

[spiderman061]

Hocam Çalışmadı

Sub TXTSAVE()
Dim a As Long, x As Long, b As Long, dosya As String
For a = 1 To ThisWorkbook.Worksheets.Count
If Not Sheets(a).Name = "OKULLAR" And Not Sheets(a).Name = "KONTROL" And Not Sheets(a).Name = "HAM_TXT" And Not Sheets(a).Name = "BICIMLENDIRME" And Not Sheets(a).Name = "TURKCE" And Not Sheets(a).Name = "MATEMATIK" And Not Sheets(a).Name = "FEN_BILIMLERI" Then
x = Sheets(a).Cells(Rows.Count, "C").End(3).Row
dosya = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Sheets(a).Name & ".txt"
Open dosya For Output As #1
For b = 1 To x
Print #1, Sheets(a).Cells(b, "C")
Next
Close #1
End If
Next
End Sub

 

[EmrExcel16]

Kodları karıştırıyorsunuz sanırım , sorduğunuz sorudaki kod ile çalışmadı dediğiniz kodlar farklı , tekrar inceleyiniz..

 

[PLİNT]

Merhaba
Benim eklediğim kodlar içinse aşağıdaki gibi deneyin

Sub TXTSAVE()
Dim a As Long, x As Long, b As Long, dosya As String
For a = 1 To ThisWorkbook.Worksheets.Count
If Not Sheets(a).Name = "OKULLAR" And Not Sheets(a).Name = "KONTROL" And Not Sheets(a).Name = "HAM_TXT" And Not Sheets(a).Name = "BICIMLENDIRME" And Not Sheets(a).Name = "TURKCE" And Not Sheets(a).Name = "MATEMATIK" And Not Sheets(a).Name = "FEN_BILIMLERI" Then
x = Sheets(a).Cells(Rows.Count, "C").End(3).Row
If Dir("C:\TXT", vbDirectory) = "" Then MkDir "C:\TXT"
dosya = "C:\TXT\" & Sheets(a).Name & ".txt"
Open dosya For Output As #1
For b = 1 To x
Print #1, Sheets(a).Cells(b, "C")
Next
Close #1
End If
Next
End Sub

 

[spiderman061]

Adamsın