• DİKKAT

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

Kritere Göre TXT Dosyası Oluşturma

Y

yorum.halil

Katılım
16 Aralık 2007
Mesajlar
151
Excel Vers. ve Dili
Office 2007
Üstadlarım hepinize iyi akşamlar. Ekteki dosya ile ilgili bir sorum olacak.

Ekteki dosyada bir tuş ile txt dosyası oluşturabiliyorum. Fakat sizlerden isteğim şu. Benim buradan öğrendiğim kod ile yaptığım tuş ile bütün satırlara ait txt dosyası oluşuyor. Benim isteğim ise txt oluşurken telefon numarası olanları alsın, yada durumu bölümünde "aktif" yazanları alsın. Yani kritere göre txt oluşacak. İşin mantığını biliyorum ama kodda nasıl yapacağımı çözemedim. Açıklamalar örnek dosyada mevcut. Şimdiden tşk.

Sub AKTAR()
Dim i, sat As Integer
sat = [A65536].End(3).Row
Open ThisWorkbook.Path & "\LISTE.txt" For Output As #1
For i = 3 To 402
Print #1, Cells(i, 5) & ";" & "M"; ";" & Cells(i, 3) & ";" & Cells(i, 4)
Next i
Close
MsgBox "Txt Dosyası Oluşturuldu", vbInformation, "Dikkat"
End Sub
Genişletmek için tıkla ...
 

Ekli dosyalar

  • TXT.xls
    TXT.xls
    101.5 KB · Görüntüleme: 31
Son düzenleme:
Arkadaşlar bu konuda lütfen yardımlarınızı esirgemeyin. Bizim için çok önemli... En azından istenen kritesin bir tanesini bari uygulamama yardım edin....
 
Üstadlarım senim soru ikinci sayfaya düştü ama hala cevap yok... Lütfennnnn help :)
 
Kod: 
Sub printtext_herkes()
Dim arr(1 To 7)

Open ThisWorkbook.Path & "\herkes.txt" For Output As #1

With Sheets("deneme")
    For z = 2 To .[c65000].End(3).Row
        For zg = 1 To 7
            arr(zg) = .Cells(z, zg)
        Next
        x = Join(arr, ";")
        Print #1, x
    Next
End With

Close #1
End Sub

Sub printtext_aktif()
Dim arr(1 To 7)

Open ThisWorkbook.Path & "\aktif.txt" For Output As #1

With Sheets("deneme")
    For z = 2 To .[c65000].End(3).Row
        If .Cells(z, "f") = "AKTİF" Then
            For zg = 1 To 7
                arr(zg) = .Cells(z, zg)
            Next
            x = Join(arr, ";")
            Print #1, x
        End If
    Next
End With

Close #1
End Sub

Sub printtext_pasif()
Dim arr(1 To 7)

Open ThisWorkbook.Path & "\pasif.txt" For Output As #1

With Sheets("deneme")
    For z = 2 To .[c65000].End(3).Row
        If .Cells(z, "f") = "PASİF" Then
            For zg = 1 To 7
                arr(zg) = .Cells(z, zg)
            Next
            x = Join(arr, ";")
            Print #1, x
        End If
    Next
End With

Close #1
End Sub

Sub printtext_120_den_buyuk()
Dim arr(1 To 7)

Open ThisWorkbook.Path & "\120_den_buyuk.txt" For Output As #1

With Sheets("deneme")
    For z = 2 To .[c65000].End(3).Row
        If .Cells(z, "g") > 120 Then
            For zg = 1 To 7
                arr(zg) = .Cells(z, zg)
            Next
            x = Join(arr, ";")
            Print #1, x
        End If
    Next
End With

Close #1
End Sub
 
Bende şöyle bir şey hazırlamıştım.Alternatif olsun.
Kod: 
Sub telefon_olanlar()
Dim i, sat As Integer
For i = 3 To [C65536].End(3).Row
If Cells(i, 4) = Empty Then
Else
Open "C:\VERİ\" & "telefon_olanlar" & i & ".TXT" For Output As #i
Print #i, Cells(i, 5) & ";" & "M"; ";" & Cells(i, 3) & ";" & Cells(i, 4)
'         CEPTELEFONU        CİNSİYET        ADI                SOYADI
End If
Next i
Close
MsgBox "Txt Dosyası Oluşturuldu", vbInformation, "Dikkat"
End Sub

Sub aktif_olanlar()
Dim i, sat As Integer
For i = 3 To [C65536].End(3).Row
If Cells(i, 6) = "AKTİF" Then
Open "C:\VERİ\" & "aktif" & i & ".TXT" For Output As #i
Print #i, Cells(i, 5) & ";" & "M"; ";" & Cells(i, 3) & ";" & Cells(i, 4)
'         CEPTELEFONU        CİNSİYET        ADI                SOYADI
Else
End If
Next i
Close
MsgBox "Txt Dosyası Oluşturuldu", vbInformation, "Dikkat"
End Sub
Sub pasif_olanlar()
Dim i, sat As Integer
For i = 3 To [C65536].End(3).Row
If Cells(i, 7).Value > 120 Then
Open "C:\VERİ\" & "pasif" & i & ".TXT" For Output As #i
Print #i, Cells(i, 5) & ";" & "M"; ";" & Cells(i, 3) & ";" & Cells(i, 4)
'         CEPTELEFONU        CİNSİYET        ADI                SOYADI
Else
End If
Next i
Close
MsgBox "Txt Dosyası Oluşturuldu", vbInformation, "Dikkat"
End Sub
Sub büyükler()
Dim i, sat As Integer
For i = 3 To [C65536].End(3).Row
If Cells(i, 6) = "PASİF" Then
Open "C:\VERİ\" & "buyuk" & i & ".TXT" For Output As #i
Print #i, Cells(i, 5) & ";" & "M"; ";" & Cells(i, 3) & ";" & Cells(i, 4)
'         CEPTELEFONU        CİNSİYET        ADI                SOYADI
Else
End If
Next i
Close
MsgBox "Txt Dosyası Oluşturuldu", vbInformation, "Dikkat"
End Sub
 
Üstadım eline sağlık. Ufak bir sorum daha olacak. Örnek dosyadaki txt oluşturma dosyasında sütün belirterek yapıyorduk. Acaba sadece bir makroru da olsa bu şekilde ayarlamanız mümkün mü.

Print #1, Cells(i, 5) & ";" & "M"; ";" & Cells(i, 3) & ";" & Cells(i, 4)
Genişletmek için tıkla ...
 
Bu durumda prosedurler içinde şu kısımları silin.
Kod: 
        For zg = 1 To 7
            arr(zg) = .Cells(z, zg)
        Next
        x = Join(arr, ";")

Print #1, x satırını da aşağıdaki ile değiştirin.

Kod: 
Print #1, .Cells(z, 5) & ";" & "M"; ";" & .Cells(z, 3) & ";" & .Cells(z, 4)
 
ozgretmen' Alıntı:
Bende şöyle bir şey hazırlamıştım.Alternatif olsun.
Genişletmek için tıkla ...

Üstadım sütunları belirterek yapman öğrenmemiz için iyi olmuş fakat sizin kodlar ile her satır için ayrı ayrı txt dosyası oluşturuyor. Benim istediğim liste şeklide olacak. Yardımların için Tekrar tşk ederim.
 
Bu sıralar soruları anlamakta zorluk çekiyorum her nedense.:oops:Kodaları düzelttim.Yine bu da alternatif olsun.İyi geceler.
Kod: 
Sub telefon_olanlar()
Open ThisWorkbook.Path & "\tum.txt" For Output As #1
For i = 3 To [C65536].End(3).Row
If Cells(i, 4) = Empty Then
Else
Print #1, Cells(i, 5) & ";" & Cells(i, 3) & ";" & Cells(i, 4)
End If
Next i
Close
End Sub
Sub aktif_olanlar()
Open ThisWorkbook.Path & "\aktif_olanlar.txt" For Output As #1
For i = 3 To [C65536].End(3).Row
If Cells(i, 6) = "AKTİF" Then
Print #1, Cells(i, 5) & ";" & Cells(i, 3) & ";" & Cells(i, 4)
Else
End If
Next i
Close
End Sub
Sub pasif_olanlar()
Open ThisWorkbook.Path & "\pasif_olanlar.txt" For Output As #1
For i = 3 To [C65536].End(3).Row
If Cells(i, 6) = "PASİF" Then
Print #1, Cells(i, 5) & ";" & Cells(i, 3) & ";" & Cells(i, 4)
Else
End If
Next i
Close
End Sub
Sub fazla_120_olanlar()
Open ThisWorkbook.Path & "\fazla_120_olanlar.txt" For Output As #1
For i = 3 To [C65536].End(3).Row
If Cells(i, 7) > 120 Then
Print #1, Cells(i, 5) & ";" & Cells(i, 3) & ";" & Cells(i, 4)
Else
End If
Next i
Close
End Sub
 
Zeki üstadım eline sağlık sanırım gerisini ben yapabilirim. Ozgretmen üstadım seninde eline sağlık. Telefon numarası olmayanlara da txt yapıyor ama onu bir şekide sanırım çözebilirim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst