PDA

View Full Version : [SOLVED] Search Replace in Text files - Loop to Next Search & Replacement



dj44
07-22-2018, 09:08 AM
good sunday,

i am tryign to do search and replacements in text files

i found this

it only replaced the first instance and didnt move on to the next

http://www.vbaexpress.com/forum/showthread.php?36304-Batch-Text-Replace-VBA-from-Control-File




Sub repltxtfiles()


Const ForReading = 1
Const ForWriting = 2

Dim objFSO As Object
Dim objFile As Object
Dim fName As String
Dim i As Long, LR As Long
Dim strText As String, strNewText As String

LR = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

Set objFSO = CreateObject("Scripting.FileSystemObject")

For i = 2 To LR
fName = ThisWorkbook.ActiveSheet.Range("A" & i) & "\" & Range("B" & i)
If Not objFSO.FileExists(fName) Then GoTo Nexti
Set objFile = objFSO.OpenTextFile(fName, ForReading)

strText = objFile.ReadAll
objFile.Close
'Case insensitive
strNewText = Replace(strText, Range("C" & i), Range("D" & i), Compare:=vbTextCompare)
'Case sensitive
'strNewText = Replace(strText, Range("C" & i), Range("D" & i), Compare:=vbBinaryCompare)

Set objFile = objFSO.OpenTextFile(fName, ForWriting)
objFile.WriteLine strNewText

objFile.Close
Set objFile = Nothing
Nexti:
Next i

Set objFSO = Nothing
End Sub

Private Sub CommandButton1_Click()
repltxtfiles
End Sub





Worksheet set up as below

File Path (A) | File Name (B) | Search (C) | Replacement (D)

C:\Users\DJ\Desktop\ a.txt hello hi
apple cherry


I am wondering why only the first replacement and not all the others set up


thank you for your help

p45cal
07-23-2018, 04:16 AM
I've tested this here and it replaces all instances.
Perhaps something to do with your text files; could you supply an example text file, with what's being sought and replaced?

dj44
07-23-2018, 07:18 AM
Hello P,

i was just using a normal text file



_____________________________________________
Apple You can also type a Pear keyword to search online for the video that best fits your document.
To make your document look professionally produced, Word provides header, footer, cover page, and text box designs that complement each other.
_____________________________________________
It replaced the first one, but not the subsequent

thank you for testing it

p45cal
07-23-2018, 07:29 AM
OK. Without a text file etc. I can't suggest anything else. :(

dj44
07-23-2018, 08:15 AM
oh an actual text file

22609

and i tested with
Search | Replace
Apple | Car
Pear | Train


I just used this as a test

p45cal
07-23-2018, 02:44 PM
Arange your data thus (note column A has data filled to the bottom:
22610

dj44
07-24-2018, 01:58 AM
thank you my friend,

that worked

now to do a single file with lots of replacements i only added the file name below




Sub Search_Replace_TextFile()

Const ForReading = 1
Const ForWriting = 2

Dim objFSO As Object
Dim objFile As Object
Dim fName As String
Dim i As Long, LR As Long
Dim strText As String, strNewText As String

LR = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

Set objFSO = CreateObject("Scripting.FileSystemObject")

For i = 2 To LR


fName = "C:\Users\DJ\Desktop\a.txt" ' <<< Single Text file

Set objFile = objFSO.OpenTextFile(fName, ForReading)

strText = objFile.ReadAll
objFile.Close
'Case insensitive
strNewText = Replace(strText, Range("C" & i), Range("D" & i), Compare:=vbTextCompare)
'Case sensitive
'strNewText = Replace(strText, Range("C" & i), Range("D" & i), Compare:=vbBinaryCompare)

Set objFile = objFSO.OpenTextFile(fName, ForWriting)
objFile.WriteLine strNewText

objFile.Close
Set objFile = Nothing
Nexti:
Next i

Set objFSO = Nothing

End Sub



I was trying to lots of replacements in my text file, one by one is very tedious :type

But this will help me do it one press

cheers and good week!

p45cal
07-24-2018, 02:15 AM
That involves a lot of unnecessary opening and closing of the file; do it once only:
Sub Search_Replace_TextFile()
Const ForReading = 1
Const ForWriting = 2
Dim objFSO As Object
Dim objFile As Object
Dim fName As String
Dim i As Long, LR As Long
Dim strText As String

LR = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Set objFSO = CreateObject("Scripting.FileSystemObject")
fName = "C:\Users\DJ\Desktop\a.txt" ' <<< Single Text file
Set objFile = objFSO.OpenTextFile(fName, ForReading)
strText = objFile.ReadAll
objFile.Close

For i = 2 To LR
'Case insensitive
strText = Replace(strText, Range("C" & i), Range("D" & i), Compare:=vbTextCompare)
'Case sensitive
'strNewText = Replace(strText, Range("C" & i), Range("D" & i), Compare:=vbBinaryCompare)
Next i

Set objFile = objFSO.OpenTextFile(fName, ForWriting)
objFile.WriteLine strText
objFile.Close
Set objFile = Nothing
Set objFSO = Nothing
End Sub

(Tested)

If you don't want to have to put something in column A to ensure it goes through all the search/replace pairs, determine last row (LR) using another column, say C or D?
So instead of:
LR = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
use:
LR = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
or:
LR = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row

dj44
07-24-2018, 07:06 AM
Thank you for this extra help :)

thats stellar!

Have a great week!

p45cal
07-24-2018, 09:21 AM
just noticed:
'strNewText = Replace(strText, Range("C" & i), Range("D" & i), Compare:=vbBinaryCompare)
should be:
'strText = Replace(strText, Range("C" & i), Range("D" & i), Compare:=vbBinaryCompare)

Tom Jones
07-24-2018, 10:25 AM
@p45cal,

Having the data set as in post no. 6, how to change your code to take the path from column A & "/" & B, (fName = ThisWorkbook.ActiveSheet.Range("A" & i) & "" & Range("B" & i)), not directly from the code (fName = "C: \ Users \ DJ \ Desktop \ a.txt")

Thank you.

p45cal
07-24-2018, 10:37 AM
Supply a sheet (preferably an actual workbook, but a last resort is a picture) with the data as it really is (not more than 20ish rows though), including multiple file names if there are going to be more than one, then I should be able to give you a definitive answer.

Tom Jones
07-24-2018, 11:50 AM
Thanks for reply p45cal,

In attach is my file. Of course there are a lot more file then show there (3 file)

p45cal
07-24-2018, 05:06 PM
The attached has comments in the code to guide you.
The idea is that you can have your sheet like this:
22620
Where there are blank cells in columns A and B, their value is assumed to be the same as the first non-blank cell above it.
The same does NOT apply to column C and D.
The code should only open and close files when a file name (effectively) changes as it works its way down the list.
Do test it thoroughly.
This is the code but it's in the file:
Sub Search_Replace_TextFile()
Const ForReading = 1
Const ForWriting = 2
Dim objFSO As Object
Dim objFile As Object
Dim fName As String, CurrentfName As String, g As String, FolderName As String, FilName As String
Dim i As Long, LR As Long
Dim strText As String

With ActiveSheet
'Assign a few things:
LR = .Cells(Rows.Count, "C").End(xlUp).Row 'uses column C to determine extent of data to process.
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Make an initial check that A2:B2 contains a valid folder name and file name and that that file exists, otherwise abort:
fName = .Range("A" & 2).Value & "\" & .Range("B" & 2).Value
If objFSO.fileexists(fName) Then
For i = 2 To LR
'this bit handles blanks in column A and B and makesthe assumption if there's a blank it means it's the same as the first non-blank above it.
'.Range("A" & i).Select 'debug line
g = .Range("A" & i).Value
If Len(Application.Trim(g)) > 0 Then FolderName = g
g = .Range("B" & i).Value
If Len(Application.Trim(g)) > 0 Then FilName = g

fName = FolderName & "\" & FilName
If fName <> CurrentfName Then 'it's a different file so
'write/update existing file:
If Len(CurrentfName) > 0 Then '(but check that there is an open file first)
Set objFile = objFSO.OpenTextFile(CurrentfName, ForWriting)
objFile.WriteLine strText
objFile.Close
End If
'open new file and read and close:
Set objFile = objFSO.OpenTextFile(fName, ForReading)
strText = objFile.ReadAll
objFile.Close
'update current file name:
CurrentfName = fName
End If

'Case insensitive:
strText = Replace(strText, Range("C" & i), Range("D" & i), Compare:=vbTextCompare)
'Case sensitive:
'strText = Replace(strText, Range("C" & i), Range("D" & i), Compare:=vbBinaryCompare)

Next i
'update and close the last file:
Set objFile = objFSO.OpenTextFile(CurrentfName, ForWriting)
objFile.WriteLine strText
objFile.Close
Else
MsgBox "File in A2:B2 doesn't exist. Aborting"
End If
End With
Set objFile = Nothing
Set objFSO = Nothing
End Sub

Tom Jones
07-25-2018, 12:26 AM
p45cal,

Excellent. Thank you so much.