txt uzantılı dosyalarda veri değiştirme

[steppe]

Merhaba Arkadaşlar,
Elimde daha önce forum sayfasından bulduğum örnek bir uygulama mevcut.Dosya içinde ayrıntılı açıkladığım ,değişikliği yapmak istiyorum ama bir türlü beceremedim. Dosyaların içinde aynı bilgiler var. Her bir dosyaya özel değişiklik yapmak mümkün mü?
Yardımlarınız için şimdiden teşekkür ederim.

 

[halit3]

Ekli dosyayı irdeleyiniz.

Önce dosyalarınızın bulunduğu klasörü bulmak için txt dosyalarını bul komut düğmesine tıkla sonra C sütununa aranan D sütununa da değişen değerleri yazın değiştir düğmesini tıkla

kod:

Private Sub CommandButton1_Click()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
kaynak = Klasor.SELF.Path
If InStr(1, kaynak, "{") > 0 Then GoTo Atla
Range("A2:a65000").ClearContents
If Right(kaynak, 1) <> "\" Then kaynak = kaynak & "\"
Liste (kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub


Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")

If Right(yol, 1) <> "\" Then ekle = "\"

'On Error Resume Next
For Each dosya In fL.GetFolder(yol).Files
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("a1:a" & Rows.Count)) + 1
If fL.GetExtensionName(dosya) = "txt" Then
Cells(j, 1) = dosya
Cells(j, 2) = dosya.Name
End If

Next

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

Set fL = Nothing
End Sub

Private Sub CommandButton2_Click()

Dim kaynak As String
Dim tum_metin As String

For i = 2 To Cells(Rows.Count, "A").End(3).Row

kaynak = Cells(i, "A")

tum_metin = CreateObject("scripting.filesystemobject").Opentextfile(kaynak).readall


tum_metin = Replace(tum_metin, Cells(i, "c"), Cells(i, "d")) 'BÜYÜK-küçük duyarlı ve hızlı.


Open kaynak For Output As #1
Print #1, tum_metin
Close #1

Next i

MsgBox "işlem tamam"
End Sub

 

[veyselemre]

Private Sub CommandButton1_Click()
    Dim fso, MyFile, FileName, ReadAllTextFile 
    Set fso = CreateObject("Scripting.FileSystemObject")
    For i = 1 To [a65536].End(3).Row
        FileName = ThisWorkbook.Path & "\" & Cells(i, 1)
        Set MyFile = fso.OpenTextFile(FileName, 1)
        If MyFile.AtEndOfStream Then
            ReadAllTextFile = ""
        Else
            ReadAllTextFile = MyFile.ReadAll
            ReadAllTextFile = Replace(ReadAllTextFile, Cells(i, 2), Cells(i, 3))
            MyFile.Close
            
            Set MyFile = fso.OpenTextFile(FileName, 2, True, 0)
            MyFile.Write ReadAllTextFile
            MyFile.Close
        End If
    Next i
End Sub

 

[steppe]

Halit3 ve veyselemre Hocalarım,
Her ikinize de yardımlarınız için çok teşekkür ederim.

 

[steppe]

Merhaba Arkadaşlar,
Mevcut kodla:txt uzantılı dosya içinde kelime bazlı değiştirme yapılabiliyor.
Cümle ve kısa bir parağraf gibi değişikleri yapabilir miyiz?
Yardımlarınız için şimdiden teşekkürler

 

[steppe]

Merhabalar,

Sub degistir()
Dim kaynak As String
Dim tum_metin As String
For i = 2 To Cells(Rows.Count, "A").End(3).Row
kaynak = Cells(i, "A")
tum_metin = CreateObject("scripting.filesystemobject").Opentextfile(kaynak).readall
tum_metin = Replace(tum_metin, Cells(i, "E"), Cells(i, "F")) 'BÜYÜK-küçük duyarlı ve hızlı.
Open kaynak For Output As #1
Print #1, tum_metin
Close #1
Next i
MsgBox "işlem tamam"
End Sub

Yukarıdaki kodda txt uzantılı dosyada veriler gayet güzel değiştiriliyor.Yalnız türkçe karekterleri desteklemiyor.Örnek ö,ç gibi harflerin yerine � işareti çıkıyor.

Yardımlarınız için şimdiden teşekkür ederim.