Klasördeki dosyaları birleştirme

[Belleksizz]

Merhaba masa üstümde bir klasör var içerisinde 500 adet .txt ( metin belgesi) var. Bu metin belgelerinin isimleri Tx101 Tx108 Tx 200 Gibi değişiyor her bir metin belgesi depomdaki 1 rafı belirtiyor ve metin belgelerinin içlerinde ise barkod numaraları var ben şu anda hali hazırda bir excel acıyorum sonra TX101 yazan metin belgesini açıyorum içerisindeki barkodları kopyalıyorum A Stununa yapıştırıyorum B stününa da TX101 yazıyorum tüm aşagıya doğru tüm satırlara uyguluyorum hemen bitiş noktasına diğer metin belgesindeki barkodları koyuyorum b sutununa da onun txt de yazan tx 108 109 gibi adını yapıştırıyorum

Bu işlemi sürekli yaptığım için işlem yormaya başladı artık bu konuda harici bir program veya excelde bir yöntem ile daha hızlı çözebilirmiyiz

 

[RBozkurt]

Deneyin,

Sub MetinDosyalariniBirlestir()
    Dim KlasorYolu As String
    Dim DosyaAdi As String
    Dim MetinSatiri As String
    Dim SatirNumarasi As Long
    Dim DosyaNumarasi As Integer
    Dim CalismaSayfasi As Worksheet
    
    KlasorYolu = KlasorSec("Klasör Seçin")
    If KlasorYolu = "" Then Exit Sub
    
    Set CalismaSayfasi = ThisWorkbook.Worksheets.Add
    CalismaSayfasi.Name = "MetinVerileri"
    
    DosyaAdi = Dir(KlasorYolu & "\*.txt")
    SatirNumarasi = 1
    
    Do While DosyaAdi <> ""
        DosyaNumarasi = FreeFile
        Open KlasorYolu & "\" & DosyaAdi For Input As #DosyaNumarasi
        Do Until EOF(DosyaNumarasi)
            Line Input #DosyaNumarasi, MetinSatiri
            CalismaSayfasi.Cells(SatirNumarasi, 1).Value = DosyaAdi
            CalismaSayfasi.Cells(SatirNumarasi, 2).Value = MetinSatiri
            SatirNumarasi = SatirNumarasi + 1
        Loop
        
        Close #DosyaNumarasi
        DosyaAdi = Dir
    Loop
    
    MsgBox "Tüm dosyalar birleştirildi!", vbInformation
End Sub

Function KlasorSec(Optional Aciklama As String = "Klasör Seçin") As String
    Dim ShellUygulama As Object
    Set ShellUygulama = CreateObject("Shell.Application").BrowseForFolder(0, Aciklama, 0, 17)
    If Not ShellUygulama Is Nothing Then
        KlasorSec = ShellUygulama.Self.Path
    Else
        KlasorSec = ""
    End If
End Function

 

[Korhan Ayhan]

Kullandığınız sürümde bu işlemleri otomatik yapabileceğini menü var. Bu menüyü kurcalamanızı öneririm..

 

[Belleksizz]

Korhan bey merhaba bu yöntem ile tek bir dosyayı alıyor bu işime yaramadı malesef

 

[Belleksizz]

Deneyin,

Sub MetinDosyalariniBirlestir()
    Dim KlasorYolu As String
    Dim DosyaAdi As String
    Dim MetinSatiri As String
    Dim SatirNumarasi As Long
    Dim DosyaNumarasi As Integer
    Dim CalismaSayfasi As Worksheet
   
    KlasorYolu = KlasorSec("Klasör Seçin")
    If KlasorYolu = "" Then Exit Sub
   
    Set CalismaSayfasi = ThisWorkbook.Worksheets.Add
    CalismaSayfasi.Name = "MetinVerileri"
   
    DosyaAdi = Dir(KlasorYolu & "\*.txt")
    SatirNumarasi = 1
   
    Do While DosyaAdi <> ""
        DosyaNumarasi = FreeFile
        Open KlasorYolu & "\" & DosyaAdi For Input As #DosyaNumarasi
        Do Until EOF(DosyaNumarasi)
            Line Input #DosyaNumarasi, MetinSatiri
            CalismaSayfasi.Cells(SatirNumarasi, 1).Value = DosyaAdi
            CalismaSayfasi.Cells(SatirNumarasi, 2).Value = MetinSatiri
            SatirNumarasi = SatirNumarasi + 1
        Loop
       
        Close #DosyaNumarasi
        DosyaAdi = Dir
    Loop
   
    MsgBox "Tüm dosyalar birleştirildi!", vbInformation
End Sub

Function KlasorSec(Optional Aciklama As String = "Klasör Seçin") As String
    Dim ShellUygulama As Object
    Set ShellUygulama = CreateObject("Shell.Application").BrowseForFolder(0, Aciklama, 0, 17)
    If Not ShellUygulama Is Nothing Then
        KlasorSec = ShellUygulama.Self.Path
    Else
        KlasorSec = ""
    End If
End Function

RBozkurt merhaba
Sorunsuz çalıştı çok teşekkürler

 

[RBozkurt]

RBozkurt merhaba
Sorunsuz çalıştı çok teşekkürler

Kolay gelsin.

 

[Biolightant]

Alternatif olsun,
@Korhan Ayhan Önerdiği gibi Veri - Metinden Veri Al
( Benim Office Sürümde bu şekilde, 365 sürümünde ki menüyü bilemiyorum )
Makro kaydet le gördüğüm QueryTables.add yöntemi ile
birden fazla dosya için döngüye sokup veri alınabiliyor.

Sub TxtQueryTable()
    Dim folderPath As String
    Dim txtFile As String
    Dim destCell As Range
    Dim ws As Worksheet
    Dim fd As FileDialog
    Dim SonSatir As Long
    Dim VeriSatirSayisi As Long

    ' FileDialog nesnesini oluştur
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    fd.Title = "TEXT dosyalarınızın olduğu klasörü seçin"
    
    ' FileDialog'u göster ve kullanıcı seçimini kontrol et
    If fd.Show = -1 Then ' Kullanıcı seçim yaptıysa
        folderPath = fd.SelectedItems(1)
    Else
        MsgBox "Herhangi bir klasör seçilmedi!", vbExclamation
        Exit Sub
    End If

    ' Klasördeki TXT dosyalarını kontrol et
    txtFile = Dir(folderPath & "\*.txt")
    If txtFile = "" Then
        MsgBox "Seçilen klasörde hiç TXT dosyası bulunamadı!", vbExclamation
        Exit Sub
    End If

    ' Yeni bir çalışma sayfası oluştur
    Set ws = ThisWorkbook.Sheets.Add
    Set destCell = ws.Range("A1") ' Yazmaya A1 hücresinden başla

    ' Klasördeki tüm TXT dosyalarını döngüye al
    Do While txtFile <> ""
        ' Her bir TXT dosyasını işleme al
        With ws.QueryTables.Add(Connection:="TEXT;" & folderPath & "\" & txtFile, Destination:=destCell)
            .TextFileParseType = xlDelimited
            .TextFileCommaDelimiter = True
            .Refresh BackgroundQuery:=False
            .Delete ' Bağlantıyı kaldır
        End With

        ' İşlenen veri miktarını hesapla
        VeriSatirSayisi = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row - destCell.Row + 1

        ' B sütununa dosya ismini yazdır (her veri satırı için)
        ws.Range(ws.Cells(destCell.Row, 2), ws.Cells(destCell.Row + VeriSatirSayisi - 1, 2)).Value = Replace(txtFile, ".txt", "")
        
        ' Sonraki dosya için destCell ve txtFile'i güncelle
        Set destCell = ws.Cells(ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1, 1)
        txtFile = Dir
    Loop

    MsgBox "Tüm TXT dosyaları başarıyla işlendi!" & vbCrLf & "Çalışma sayfası: " & ws.Name, vbInformation
End Sub

 

[Korhan Ayhan]

Korhan bey merhaba bu yöntem ile tek bir dosyayı alıyor bu işime yaramadı malesef

Pardon... Evet bahsettiğiniz yerden tek dosya bağlantısı yapılıyor. Paylaştığım resmi güncelledim. Güncel resimden işlemi yapabilirsiniz.

İşlem yapacağınız TXT dosyalarını tek klasör altına alarak işlemi yapabilirsiniz.