Toplu içe Aktarma

[ozanca024]

Aynı klasör içinde listelenmiş birden çok .txt,.xsr,.csv vb. uzantılı metin dosyalarını excele tablo olarak nasıl aktarabilir. Bir tane olduğu zaman yapıyorum ama otomatik dosyayı çağırıp , excel çalışma sayfasına da çağrılan dosyaya uygun bir isim verirse harika olur. Yardımcı olmak isteyenlere teşekkür ederim.

Makro:

Sub Makro1()
'
' Makro1 Makro
'

'
    ActiveWorkbook.Worksheets.Add
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\Users\Admin\Desktop\aktarma\liste (1).xsr", Destination:=Range( _
        "$A$1"))
        .CommandType = 0
        .Name = "liste (1)"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 1254
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
        .TextFileFixedColumnWidths = Array(16, 8, 10, 19, 10)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
End Sub

 

[esalci]

Aşağıdaki kod açık excel kitabına bir dizindeki ilgili dosyalar için aynı dosya isminde ayrı sheetler açıyor. Dosya isimlerinde geçersiz karakter olmamalı. Verdiğin kodu da eklemeye çalıştım. Gerekli diğer açıklamalar kod içerisinde verilmiştir.

Sub LoopThroughFiles()
  Dim dosya, dizin, uzanti, tumdizin As Variant
  dizin = "c:\testfolder\" '''İLGİLİ DİZİN SOLDAKİ GİBİ EKLENMELİ
  dosya = Dir(dizin)
  
  While (dosya <> "")
  
        uzanti = Right(dosya, Len(dosya) - InStr(dosya, "."))
    
        If uzanti = "txt" Or uzanti = "xsr" Or uzanti = "csv" Then  '''DAHA BAŞKA DOSYA TİPLERİ VARSA BURAYA SOLDAKİ GİBİ EKLENMELİ '''
      
            With ThisWorkbook
                .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = Left(dosya, Len(dosya) - Len(uzanti) - 1)
            End With
            
            
            '''YAPILACAK İŞLEMLER BURDA BAŞLIYOR'''
            
            tumdizin = "TEXT;" & dizin & dosya
            With Sheets(Sheets.Count).QueryTables.Add(Connection:=tumdizin, Destination:=Range("$A$1"))
                .CommandType = 0
                .Name = dosya
                .FieldNames = True
                .RowNumbers = False
                .FillAdjacentFormulas = False
                .PreserveFormatting = True
                .RefreshOnFileOpen = False
                .RefreshStyle = xlInsertDeleteCells
                .SavePassword = False
                .SaveData = True
                .AdjustColumnWidth = True
                .RefreshPeriod = 0
                .TextFilePromptOnRefresh = False
                .TextFilePlatform = 1254
                .TextFileStartRow = 1
                .TextFileParseType = xlFixedWidth
                .TextFileTextQualifier = xlTextQualifierDoubleQuote
                .TextFileConsecutiveDelimiter = False
                .TextFileTabDelimiter = True
                .TextFileSemicolonDelimiter = False
                .TextFileCommaDelimiter = False
                .TextFileSpaceDelimiter = False
                .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
                .TextFileFixedColumnWidths = Array(16, 8, 10, 19, 10)
                .TextFileTrailingMinusNumbers = True
                .Refresh BackgroundQuery:=False
            End With
            
            '''YAPILACAK İŞLEMLER BURDA BİTİYOR''
       End If
     dosya = Dir
  Wend
End Sub

 

[ozanca024]

Sn. Esalci, cevabınız için teşekkür ederim. İlgili kodu çalıştırdığım zaman CommandType = 0 ve .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = Left(dosya, Len(dosya) - Len(uzanti) - 1) satırlarında hata alıyorum. İyi Günler Diliyorum