Txt içeriği düzenlemek

[k0081]

Merhaba arkadaşlar;

İki örnek dosya ekliyorum..

http://www.dosya.tc/server8/mdelrp/ornek.rar.html

http://s6.dosya.tc/server9/zxd62y/ornek-2.rar.html

--------------------------------------

linkte vermiş olduğum dosyanın içeriğini command buton kullanarak , nasıl alt altta düzenleyebilirim?


istenen format :

12ø10/30 l=155
16ø10/30 l=405
17ø10/30 l=830
27ø10/30 l=165
...
...
...
...

gibi..

... sıralamanın çapa göre veya uzunluğu göre bir önemi yoktur. içeriğin alt alta olması yeterlidir..

Yardımcı arkadaşa şimdiden teşekkür ediyorum.

 

[halit3]

Kod klasörün içine bir klasör oluşturuyor ve text dosyalarını excele çeviriyor ve ayrıca farklı text kayıtı yapıyor.

kod:

Dim Sayfa_adı

Sub csvye_cevir2()

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

Set fs = CreateObject("Scripting.FileSystemObject")

If fs.FolderExists((Klasor.Items.Item.Path & "\" & "Excel Dosyaları")) = True Then
fs.DeleteFolder (Klasor.Items.Item.Path & "\" & "Excel Dosyaları")
End If




Liste2 (Klasor.Items.Item.Path)

Liste3 (Klasor.Items.Item.Path & "\" & "Excel Dosyaları")

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

ad = yol & "\" & "Excel Dosyaları"

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

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
ActiveWorkbook.SaveAs ad & "\" & fs.GetBaseName(dosya) & "." & uzanti2, FileFormat:=FileFormatNum '6   '-4158 'xlText
ActiveWindow.Close

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


Private Sub Liste3(yol As String)
Dim fL As Object, f As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject")

For Each dosya In fL.GetFolder(yol).Files

If fL.GetFileName(dosya) = ThisWorkbook.Name Or Mid(fL.GetFileName(dosya), 1, 2) = "~$" Then
GoSub atla1
End If

aranan_Uzanti = fL.GetExtensionName(Application.AddIns.Item(1).FullName)
uzanti = fL.GetExtensionName(dosya)

If aranan_Uzanti = "xlam" Then
If uzanti = "xls" Or uzanti = "xlsm" Or uzanti = "xlsx" Or uzanti = "xlsb" Then

Else
GoSub atla1
End If
End If

If aranan_Uzanti = "xla" Then
If uzanti = "xls" Then

Else
GoSub atla1
End If
End If


Open yol & "\" & fL.GetBaseName(dosya) & "y .txt" For Output As #1

Dim wb As Workbook
Set wb = Workbooks.Open(dosya)

Set Sh = ActiveWorkbook.Sheets(ActiveSheet.Name)
If WorksheetFunction.CountA(Sh.Cells) > 0 Then
sat = Sh.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sut = Sh.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Else
Exit Sub
End If

For i = 1 To sat

For j = 1 To sut
If ActiveWorkbook.Sheets(ActiveSheet.Name).Cells(i, j).Value <> "" Then
sat1 = sat1 + 1
ThisWorkbook.Sheets(Sayfa_adı).Cells(sat1, 1).Value = Trim(ActiveWorkbook.Sheets(ActiveSheet.Name).Cells(i, j).Value)
Print #1, Trim(ActiveWorkbook.Sheets(ActiveSheet.Name).Cells(i, j).Value)
End If
Next
Next
Close #1
wb.Close


atla1:
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).SubFolders
Liste3 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

 

[k0081]

halit3

Hocam kod için teşekkürler. ;

Şimdi klasörün içine yeni bir klasör oluşturmaya gerek yok., buna bağlı olarak excel dosyasına çevirmeye de gerek yok.

sadece txt dosyasını düzenlemek istiyorum. tabi excel macrosu ile tam olarak yapılabilirmi.. emin de değilim.

 

[halit3]

kod:

Sub verial()

Columns("A:B").ClearContents
  


yol = ThisWorkbook.Path
ZBasla = TimeValue(Now)
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "Tüm Dosyalar", "*.*", 1
.Filters.Add "Resim Files", "*.jpg", 1
.Filters.Add "Text Files", "*.txt", 1
.Filters.Add "Excel Text", "*.csv", 1
.Filters.Add "Excel Files", "*.xl*", 1
.FilterIndex = 3

.InitialFileName = yol
.Show
'.Execute
If .SelectedItems.Count = 0 Then GoTo atla2
dosya = .SelectedItems(1)

'Application.ScreenUpdating = False
sat = 0
say = 0
say2 = 0

'On Error Resume Next

Set fl = CreateObject("Scripting.FileSystemObject")

Open yol & "\" & fl.GetBaseName(dosya) & "y .txt" For Output As #2

Open dosya For Input As #1
 
Do While Not EOF(1)
Line Input #1, deg1

sut = 1
say = say + 1

deg5 = Replace(Replace(Replace(Replace(deg1, Chr(9), "#"), " ", "?"), Chr(10), "?"), Chr(13), "?")

For k = 1 To 10
deg5 = Replace(Replace(deg5, "##", "#"), "??", "?")
Next k

For k = 1 To 10
deg5 = Replace(deg5, "#", " ")
Next k

For k = 1 To 10
deg5 = Replace(deg5, " ?", "?")
Next k

For k = 1 To 10
deg5 = Replace(deg5, " ", "?")
Next k

deg5 = Replace(deg5, "?(üst)", "(üst)")
deg5 = Replace(deg5, "?(alt)", "(alt)")

deg5 = Mid(deg5, 1, Len(deg5) - 1)

deg1 = Mid(deg5, 2, Len(deg5))

deg2 = Split(Trim(deg1), "?")
If UBound(deg2) > 0 Then
y = 0
For i = 0 To UBound(deg2)
y = y + 1

If y Mod 2 = 1 Then

sat = sat + 1
'End If
sut = 1
Print #2, deg2(i) & " " & deg2(i + 1)
End If
Cells(sat, sut) = deg2(i)

sut = sut + 1
Next i
End If


Loop

Close #1

Close #2
atla2:
Application.ScreenUpdating = True
zBitis = TimeValue(Now)
MsgBox "işlem tamam Geçen Süre " & CDate(zBitis - ZBasla) & Chr(10) & "veriler alınmıştır.", vbOKOnly + vbInformation, "uyarı"

End With

End Sub

 

[halit3]

birde bunu dene

Sub tet_oku()

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

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")

ReDim veri(5000)

For Each dosya In fs.GetFolder(yol).Files

If LCase(fs.GetExtensionName(dosya)) = "txt" Then


say2 = 0
Open dosya For Input As #1
 
Do While Not EOF(1)
Line Input #1, deg1


deg5 = Replace(Replace(Replace(Replace(deg1, Chr(9), "#"), " ", "?"), Chr(10), "?"), Chr(13), "?")

For k = 1 To 10
deg5 = Replace(Replace(deg5, "##", "#"), "??", "?")
Next k

For k = 1 To 10
deg5 = Replace(deg5, "#", " ")
Next k

For k = 1 To 10
deg5 = Replace(deg5, " ?", "?")
Next k

For k = 1 To 10
deg5 = Replace(deg5, " ", "?")
Next k

deg5 = Replace(deg5, "?(üst)", "(üst)")
deg5 = Replace(deg5, "?(alt)", "(alt)")


If Right(deg5, 1) = "?" Then
deg5 = Mid(deg5, 1, Len(deg5) - 1)
Else
deg5 = deg5
End If

If Left(deg5, 1) = "?" Then
deg1 = Mid(deg5, 2, Len(deg5))
Else
deg1 = deg5
End If

deg2 = Split(Trim(deg1), "?")

If UBound(deg2) > 0 Then
y = 0
For i = 0 To UBound(deg2)
y = y + 1
If y Mod 2 = 1 Then
say2 = say2 + 1
veri(say2) = deg2(i) & " " & deg2(i + 1)
End If

Next i
End If

Loop
Close #1

Open dosya For Output As #2
For t = 1 To say2
Print #2, veri(t)
Next
Close #2

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

 

[k0081]

Halit Hocam çok teşekkür ediyorum., Tamamdır.. son göndermiş olduğunuz kod ( #5 ) tam istediğimi yapıyor.. elinize-Yüreğinize sağlık...

 

[halit3]

Teşekkürler iyi çalışmalar