Dosya veya kitap isimlerini içersindeki değerlele aynı sayfaya çekme hk.

[isoo_34]

Merhaba arkadaşlar,
Aşağıda belirtmiş olduğum koda dosya isimlerinide çekmesini sağlaya bileceğim eklentiyi nasıl sağlaya bilirim yardımcı olur musunuz? Şimdiden Teşekkür ederim..

Sub Makro1()

Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim ws As Worksheet

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder("C:\--------\TIP DATA\ARALIK 2019 TIP\HT\data")
For Each oFile In oFolder.Files
'Debug.Print oFile.Name
sagdan = Left((Right(oFile.Name, 5)), 1)

If sagdan = 1 Then
say = Sheets("1").Cells(Rows.Count, "a").End(xlUp).Row + 1
Set ws = Sheets("1")

ElseIf sagdan = 2 Then
say = Sheets("2").Cells(Rows.Count, "a").End(xlUp).Row + 1
Set ws = Sheets("2")

ElseIf sagdan = 3 Then
Set ws = Sheets("3")
say = Sheets("3").Cells(Rows.Count, "a").End(xlUp).Row + 1

ElseIf sagdan = 4 Then
Set ws = Sheets("4")
say = Sheets("4").Cells(Rows.Count, "a").End(xlUp).Row + 1

End If

With ws.QueryTables.Add(Connection:= _
"TEXT;C:\Users\umut\Desktop\TIP DATA\ARALIK 2019 TIP\HT\data\" & oFile.Name, _
Destination:=ws.Cells(say, 1))
.FieldNames = True
.AdjustColumnWidth = True
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With

Next

Set oFile = Nothing
Set oFolder = Nothing
Set oFSO = Nothing

End Sub