Text dosyadan sıralı veri alma

[Tevfik_Kursun]

Merhaba Arkadaşlar,
Ekli txt dosyalarındaki 1 den 160 a kadar olan sıralı bir harflik değerleri excele alırken mümkünse ilk sütun dosya_adı, ikinci sütun tren gibi dizilmiş değerler olarak almak istiyorum. (Txt dosyalardaki ilk 2 satır, 14. satırın sonundaki 36 karakter, 23. satırın sonundaki 13 karakter, gereksiz) (Not : Sadece excele düzgün alınması bile başlangıç için yeterli olabilir.)
Saygılarımla
örnek dosyalar

 

[halit3]

Belki bu kod işinizi görür
kod klasördeki bütün bütün kodları excell ceviriyor.

Dim msg1
Dim Klasor2
Sub txt_cevir()

Sayfa_adı = ActiveSheet.Name
Set Klasor = CreateObject("shell.application").browseforfolder(0, "Lütfen bir klasör seçiniz", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla
Application.ScreenUpdating = False
Application.DisplayAlerts = False

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

Klasor2 = ""
Klasor2 = Kaynak & "Excel Dosyaları"

If CreateObject("Scripting.FileSystemObject").FolderExists(Klasor2) = False Then
MkDir Klasor2
End If

 msg1 = MsgBox("Txt Dosyalarını" & Chr(10) & Chr(10) & _
 "silmek için  EVET tıklayınız. " & Chr(10) & Chr(10) & _
"silmemek için HAYIR tıklayınız.", vbYesNo + vbInformation, "u y a r ı !")

Liste2 (Klasor.Items.Item.Path)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Set Klasor = Nothing

End Sub


Private Sub Liste2(yol As String)
Dim fs As Object, f As Object
Set fs = CreateObject("Scripting.FileSystemObject")

uzanti = fs.GetExtensionName(ThisWorkbook.Name)

Dim wb As Workbook

For Each dosya In fs.getfolder(yol).Files
If ThisWorkbook.Name <> dosya.Name Then
If LCase(fs.GetExtensionName(dosya)) = "txt" Then

If uzanti = "xls" Then
FileFormatNum = -4143
uzanti2 = "xls"
ElseIf uzanti = "xlsm" Then
FileFormatNum = 51
uzanti2 = "xlsx"
ElseIf uzanti = "xlsx" Then
FileFormatNum = 51
uzanti2 = "xlsx"
End If

Workbooks.OpenText Filename:=dosya, DataType:=xlDelimited, Tab:=True



Application.DisplayAlerts = False

Cells(23, "s") = ""
Cells(14, "s") = ""
Rows("1:2").Delete Shift:=xlUp
Columns("A:Z").EntireColumn.AutoFit
Range("A1").Select
ActiveWorkbook.SaveAs Klasor2 & "\" & fs.GetBaseName(dosya) & "." & uzanti2, FileFormat:=FileFormatNum '6   '-4158 'xlText
ActiveWindow.Close
If msg1 = vbYes Then
fs.DeleteFile dosya
End If

End If
End If
Next

On Error GoTo sonraki
For Each f In fs.getfolder(yol).subfolders
Liste2 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

 

[halit3]

2 nolu mesajdaki kodu güncelledim

 

[Tevfik_Kursun]

Sayın Halit3 Hocam,
İlginize çok teşekkür ederim.
Saygılarımla

 

[halit3]

Teşekkürler iyi çalışmalar

 

[Tevfik_Kursun]

Sayın Halit3 Hocam,
160 olacağına bir sütun daha eklense (225 e kadar) başka değişiklik ister miydi?
Saygılarımla

 

[halit3]

Bir dene bakalım sonuç ne olacak

 

[Tevfik_Kursun]

Merhaba,
170 soruyu denedim, sorun yok. 225 soruluk olanı yarın deneyeceğim.
Saygılarımla

 

[Tevfik_Kursun]

Merhaba Halit3 Hocam,
225 soruluk olanı da denedim. Bunda da sorun yok. İlginize çok teşekkür ederim. Aşağıdakileri de ekleyebilir miyiz acaba?
İşleme başlarken hiç sormadan bulunduğu klasörden yapsa ve işlem bittiğinde oluşan excel dosyaları tek dosyada toplasa kontrol daha kolay olabilir diye düşünürüm.
Saygılarımla

 

[halit3]

kod:

Dim Klasor2
Sub txt_cevir()

Sayfa_adı = ActiveSheet.Name
Set Klasor = CreateObject("shell.application").browseforfolder(0, "Lütfen bir klasör seçiniz", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla
Application.ScreenUpdating = False
Application.DisplayAlerts = False

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

Klasor2 = Kaynak & "Excel Dosyaları"

If CreateObject("Scripting.FileSystemObject").FolderExists(Klasor2) = False Then
MkDir Klasor2
End If

Liste2 (Klasor.Items.Item.Path)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Set Klasor = Nothing

End Sub


Private Sub Liste2(yol As String)
Dim fs As Object, f As Object
Set fs = CreateObject("Scripting.FileSystemObject")

uzanti = fs.GetExtensionName(ThisWorkbook.Name)

Dim wb As Workbook

For Each dosya In fs.getfolder(yol).Files
If ThisWorkbook.Name <> dosya.Name Then
If LCase(fs.GetExtensionName(dosya)) = "txt" Then

If uzanti = "xls" Then
FileFormatNum = -4143
uzanti2 = "xls"
ElseIf uzanti = "xlsm" Then
FileFormatNum = 51
uzanti2 = "xlsx"
ElseIf uzanti = "xlsx" Then
FileFormatNum = 51
uzanti2 = "xlsx"
End If

Workbooks.OpenText Filename:=dosya, DataType:=xlDelimited, Tab:=True

Application.DisplayAlerts = False

Cells(23, "s") = ""
Cells(14, "s") = ""
Rows("1:2").Delete Shift:=xlUp
Columns("A:Z").EntireColumn.AutoFit
Range("A1").Select
ActiveWorkbook.SaveAs Klasor2 & "\" & fs.GetBaseName(dosya) & "." & uzanti2, FileFormat:=FileFormatNum
ActiveWindow.Close
'fs.DeleteFile dosya
End If
End If
Next

On Error GoTo sonraki
For Each f In fs.getfolder(yol).subfolders
Liste2 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

 

[Tevfik_Kursun]

Günaydın,
Mesaj kısmını ben de remlemiştim, olsun yine de ilginize teşekkür ederim.
Saygılarımla