• DİKKAT

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

Birden fazla metin dosyasından veri almak

H

hknylcn

Katılım
9 Temmuz 2012
Mesajlar
21
Excel Vers. ve Dili
2021 - Türkçe
Merhaba, elimden yaklaşık 300-400 adet txt dosyası var. Benim istediğim bir klasör içindeki tüm metin dosyalarının sırayla ismini A1 hücresine metin dosyasının her satırını B1,C1,D1... hücrelerine yazdırmak ve daha sonra bunun tam tersini yaparak metin dosyalarını güncellemek. Ekteki dosyada istediğimi anlatmaya çalıştım umarım yardımcı olursunuz.
 

Ekli dosyalar

Aşağıdaki kodu deneyiniz.

Kod: 
Sub TXT_DOSYALARINDAN_EXCELE_VERİ_AKTAR()
    Cells.ClearContents
    Satır = 1
    Sutun = 2
    
    Yol = ThisWorkbook.Path & "\"
    Dosya = Dir(Yol & "*.txt")
    
    Do
        If Dosya <> "" Then
            Open Yol & Dosya For Input As #1
                Cells(Satır, 1) = Dosya
                Do While Not EOF(1)
                    Line Input #1, Kayıt
                    Cells(Satır, Sutun) = Kayıt
                    Sutun = Sutun + 1
                Loop
            Close #1
            Satır = Satır + 1
            Sutun = 2
            Dosya = Dir
        End If
    Loop While Dosya <> ""
    
    Cells.EntireColumn.AutoFit

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Kod: 
Sub VERİLERİ_TXT_DOSYASINA_AKTAR()
    Yol = ThisWorkbook.Path & "\"
    
    Satır = Cells(Rows.Count, 1).End(3).Row
    
    For X = 1 To Satır
        Open Yol & Cells(X, 1) For Output As #1
            Sutun = Cells(X, Columns.Count).End(1).Column
            For Y = 2 To Sutun
                Print #1, Cells(X, Y)
            Next
        Close #1
    Next
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Hocam çok teşekkürler. Kusura bakmayın foruma girme imkanım olmadığından biraz geç oldu, hakkınızı helal edin.
 
Bu tam benim aradığım kodlamaydı ancak küçük bir değişiklik yapabilir misiniz?

Önce metin dosyasının ismini sonra alt satıra içeriğini sonra diğer metin dosyasının ismini ve altına içeriğini bu şekilde devam eden bir döngü... Hepsi tek excel sayfasında gerçekleşecek.

Metin dosyasının içeriğini satır satır kaydetmesi çok iyi olurdu. Yardımcı olan arkadaşlarıma şimdiden teşekkür ederim.
 
Şöyle bir şey olabilir ....

Siz, bilgisayarınızdaki text dosyalarının olduğu klasörü ("C:\TestFolder") kodlarda kendiniz değiştirirsiz .....


Kod: 
Sub Test()
    'Haluk - 09/09/2018
    '
    Dim FSO As Object, objFolder As Object, textFile As Object, myFile As Object
    Dim lRow As Long
    
    myFolder = "C:\TestFolder"
    Range("A1:A" & Rows.Count) = ""
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = FSO.GetFolder(myFolder)
    
    For Each textFile In objFolder.Files
        If LCase(Right(textFile.Name, 3)) = "txt" Then
            lRow = lRow + 1
            Range("A" & lRow) = textFile.Name
            Range("A" & lRow).Font.Color = vbRed
            Set myFile = FSO.OpenTextFile(textFile, 1, False)
            While Not myFile.AtEndOfStream
                lRow = lRow + 1
                Range("A" & lRow) = myFile.ReadLine
            Wend
            myFile.Close
        End If
        Set myFile = Nothing
    Next
    
    Set objFolder = Nothing
    Set FSO = Nothing
End Sub


.
 
Son düzenleme:
Haluk' Alıntı:
Şöyle bir şey olabilir ....

Siz, bilgisayarınızdaki text dosyalarının olduğu klasörü ("C:\TestFolder") kodlarda kendiniz değiştirirsiz .....


Kod: 
Sub Test()
    'Haluk - 09/09/2018
    '
    Dim FSO As Object, objFolder As Object, textFile As Object, myFile As Object
    Dim lRow As Long
  
    myFolder = "C:\TestFolder"
  
    Range("A1:A" & Rows.Count) = ""
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = FSO.GetFolder(myFolder)
  
    For Each textFile In objFolder.Files
        If LCase(Right(textFile.Name, 3)) = "txt" Then
            lRow = lRow + 1
            Range("A" & lRow) = textFile.Name
            Range("A" & lRow).Font.Color = vbRed
            Set myFile = FSO.OpenTextFile(textFile, 1, False)
            While Not myFile.AtEndOfStream
                lRow = lRow + 1
                Cells(lRow, 1) = myFile.ReadLine
            Wend
            myFile.Close
        End If
        Set myFile = Nothing
    Next
  
    Set objFolder = Nothing
    Set FSO = Nothing
End Sub


.
Genişletmek için tıkla ...
Aynen bu hocam. Peki bu dosyada işlem bitince mevcut txt dosyalarının üzerine kaydettirme kodu nasıl olacak?
 
Text dosyalarını Excel'e aldıktan sonra burada yapacağınız değişiklikleri yine aynı text dosyalarına mı yazdırmak istiyorsunuz?

O zaman; text dosyalarını Excel'de ayrı ayrı sayfalara yazdırmak daha iyi olur. Aşağıdaki birinci makro (Test isimli makro) bu işi yapar.

Excel sayfalarında text dosyaları için gerekli değişiklikleri yaptıktan sonra tekrar text dosyasına yazdırmak için; hangi sayfa o anda aktif sayfaysa, bu kez Test2 isimli makroyu çalıştırın.

Text dosyalarının bilgisayarda C:\TestFolder isimli klasörde olduğu kabul edilmiştir....

Kod: 
Sub Test()
    'Haluk - 09/09/2018
    '
    Dim FSO As Object, objFolder As Object, textFile As Object, myFile As Object
    Dim lRow As Long
    Dim newSh As Worksheet
   
    myFolder = "C:\TestFolder"
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = FSO.GetFolder(myFolder)
   
    For Each textFile In objFolder.Files
        lRow = 0
        If LCase(Right(textFile.Name, 3)) = "txt" Then
            newShName = FSO.getBaseName(textFile.Name)
            For i = 1 To Sheets.Count
                If Sheets(i).Name = newShName Then
                    MsgBox newShName & " adında bir sayfa mevcut, bu sayfa için işlem yapılmayacak !"
                    GoTo NextSh:
                End If
            Next
            Set newSh = Worksheets.Add(After:=Sheets(Sheets.Count))
            newSh.Name = FSO.getBaseName(textFile.Name)
            Set myFile = FSO.OpenTextFile(textFile, 1, False)
            While Not myFile.AtEndOfStream
                lRow = lRow + 1
                newSh.Range("A" & lRow) = myFile.ReadLine
            Wend
            myFile.Close
        End If
        Set myFile = Nothing
        Set newSh = Nothing
NextSh:
    Next
   
    Set objFolder = Nothing
    Set FSO = Nothing
End Sub
'
Sub Test2()
    Dim FSO As Object, myFile As Object
    Dim myFolder As String, textFile As String
    Dim noA As Long, i As Long
   
    myFolder = "C:\TestFolder"
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
   
    textFile = myFolder & Application.PathSeparator & ActiveSheet.Name & ".txt"
    noA = Range("A" & Rows.Count).End(xlUp).Row
   
    Set myFile = FSO.OpenTextFile(textFile, 2, False)
   
    For i = 1 To noA
        myFile.WriteLine Range("A" & i)
    Next
    myFile.Close
   
    Set myFile = Nothing
    Set FSO = Nothing
End Sub

.
 
Excelde aynı sayfada olması çok önemli hocam. Aksi halde txt dosyalarını kullanırdım excele almanın mantığı yok. Ben metinleri renklendirerek çeviride kullanacağım. Hepsini aynı sayfada görürsem çevirdiklerimi/çevireceklerimi % olarak görüp işlem yapabilirim. Saygılarımla...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst