TXT Oluşturma sorunu

[akmes]

Merhaba,

Ekli excel dosyasında sarı dolgu ile belirlediğim yeri (tabi seçime göre aşağıya doğru satırlar artabilir) txt olarak kaydetmek istiyorum.Ama ilgili dosyaya yüklediğimde sütunlar birbirine giriyor.Benim kullandığım txt makrosunda bir sorun olabilir mi? Konu hakkında yardımınızı rica ediyorum.

 

[halit3]

Merhaba,

Ekli excel dosyasında sarı dolgu ile belirlediğim yeri (tabi seçime göre aşağıya doğru satırlar artabilir) txt olarak kaydetmek istiyorum.Ama ilgili dosyaya yüklediğimde sütunlar birbirine giriyor.Benim kullandığım txt makrosunda bir sorun olabilir mi? Konu hakkında yardımınızı rica ediyorum.

Alternatif kod:

Option Explicit


Sub Secili_Alani_Text_Dosyasina_Yaz()

    Dim DosyaYolu   As String
    Dim YolAyirici  As String
    Dim DosyaAdi    As String
    Dim DosyaSatiri As String
    Dim alan1, deg1, deg2
    
    deg1 = "            "  '12 karekter boşluk bırakıyor
    deg2 = "!@@@@@@@@@@@@" '12 karekter sola yanaşık yapıyor
    
      
    Dim i As Long
    Dim j As Integer
    
    If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then
        MsgBox "Büyük Olasılıkla Hücreleri Seçmediniz..."
        Exit Sub
    End If
    
    DosyaYolu = ThisWorkbook.Path
    YolAyirici = Application.PathSeparator
    DosyaAdi = Split(ThisWorkbook.Name, ".")(0) & ".txt"
    
    Open DosyaYolu & YolAyirici & DosyaAdi For Output As #1
    
    For i = 1 To Selection.Rows.Count
        
        DosyaSatiri = ""
        
         For j = 1 To Selection.Columns.Count
   
           If Selection(i, j) = "" Then
           alan1 = deg1
           Else
           alan1 = Format(Selection(i, j), deg2)
           End If

            
           DosyaSatiri = DosyaSatiri & alan1
          
        Next j
        
        Print #1, DosyaSatiri
        
    Next i
    
    Close #1
    
    MsgBox "Dosya " & DosyaYolu & " Dizinine " & DosyaAdi & " Adında Oluşturuldu"

 

[akmes]

Alternatif kod:

Option Explicit


Sub Secili_Alani_Text_Dosyasina_Yaz()

    Dim DosyaYolu   As String
    Dim YolAyirici  As String
    Dim DosyaAdi    As String
    Dim DosyaSatiri As String
    Dim alan1, deg1, deg2
    
    deg1 = "            "  '12 karekter boşluk bırakıyor
    deg2 = "!@@@@@@@@@@@@" '12 karekter sola yanaşık yapıyor
    
      
    Dim i As Long
    Dim j As Integer
    
    If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then
        MsgBox "Büyük Olasılıkla Hücreleri Seçmediniz..."
        Exit Sub
    End If
    
    DosyaYolu = ThisWorkbook.Path
    YolAyirici = Application.PathSeparator
    DosyaAdi = Split(ThisWorkbook.Name, ".")(0) & ".txt"
    
    Open DosyaYolu & YolAyirici & DosyaAdi For Output As #1
    
    For i = 1 To Selection.Rows.Count
        
        DosyaSatiri = ""
        
         For j = 1 To Selection.Columns.Count
   
           If Selection(i, j) = "" Then
           alan1 = deg1
           Else
           alan1 = Format(Selection(i, j), deg2)
           End If

            
           DosyaSatiri = DosyaSatiri & alan1
          
        Next j
        
        Print #1, DosyaSatiri
        
    Next i
    
    Close #1
    
    MsgBox "Dosya " & DosyaYolu & " Dizinine " & DosyaAdi & " Adında Oluşturuldu"

Çok teşekkür ederim.Emeğinize sağlık.

 

[halit3]

Çok teşekkür ederim.Emeğinize sağlık.

Teşekkürler iyi çalışmalar