I want to search a multi line string in a text file using VBA excel macro.
I tried using InStr function.But its not working as I expected. My exact aim is to read a multi line string stored in a cell and check whether it is available in a text file. For that what i did is read the text file in to a variable, reading the string saved in the cell to another variable and comparing using Instr using binary comparison. Will InStr work for multi line string? If not any any other way to compare it?
This is my code
Public Function string_compare() As String
Dim strFilename As String
Dim strSearch As String
strFilename = "D:\test.txt"
Dim strFileContent As String
Dim iFile As Integer: iFile = FreeFile
Open strFilename For Input As #iFile
strFileContent = Input(LOF(iFile), iFile)
Close #iFile
strSearch = Sheet1.Cells(9, 1).Value
If InStr(1, strFileContent, strSearch, vbBinaryCompare) > 0 Then
MsgBox "success"
Else
MsgBox "failed"
End If
End Function
When I checked the strings both seems to be identical.Even though the strings are identical, the searching result always failing. Any suggestions will be helpful.
As Tim and Mrig suggested I removed the cr and crlf from the text as follows. Now its working fine.I could use this for comparing multi line strings.I am posting my code segment here.Hope it may help somebody else too.
Public Function stringcompare(sourcefile As String, Workbookname As Worksheet) As String
Dim strSearch As String
Dim strFileContent As String
Dim iFile As Integer: iFile = FreeFile
Open sourcefile For Input As #iFile
strFileContent = Input(LOF(iFile), iFile)
Close #iFile
strSearch = Workbookname.Cells(1, 1).Value
strFileContent = Application.WorksheetFunction.Substitute(strFileContent, vbCrLf, "")
strSearch = Application.WorksheetFunction.Substitute(strSearch, vbLf, "")
If StrComp(strFileContent, strSearch, vbBinaryCompare) = 0 Then
MsgBox "success"
Else
MsgBox "failed"
End If
End Function
Related
I have a txt file and I need to input it into a string array, where each line is one item in the array.
I've done a good deal with vba before but never editing files other than Word and Excel, so this is new to me.
The below is part of my sub (copied from somewhere online so I don't really understand it)
Sub TxtFileToArray(FilePath As String, LineArray As Variant, Optional Delimiter As String = vbCrLf)
'adapted from https://www.thespreadsheetguru.com/blog/vba-guide-text-files
Dim TextFile As Integer
Dim FileContent As String
'Open the text file in a Read State
TextFile = FreeFile
Open FilePath For Input As TextFile
'Store file content inside a variable
FileContent = Input(LOF(TextFile), TextFile)
'Close Text File
Close TextFile
It fails on the line FileContent = Input(LOF(TextFile), TextFile). Error message is:
Run-time error '62':
Input past end of file
The Variable Textfile = 1, and LOF(Textfile) = 4480
What should I do?
EDIT:
The File is full of xml data (it's actually an .odc file that's been converted to .txt). Is there something I should be doing to convert it all that to a string? Perhaps I could import it as a huge string somehow and then split it into the array?
Text File to Array
This is just an addition to a possibly upcoming answer, to show how you can use a function for your task (I don't know exactly what binary or a binary file is).
In my short investigation, it was tested with a json file. Interesting to me is that it works with Input and Binary, and that it needs vbLf instead of vbCrLf as the Delimiter.
Note that you might get one value in the array if you choose the wrong delimiter, like it happened in this case.
The test procedure will write the lines (the values in the array) to the cells in column A of the ActiveSheet.
The Code
Option Explicit
Sub TESTtextFileToArray()
Const FilePath As String = "F:\Test\2020\TXT\test.json"
Dim TextLines As Variant
' Note the 'vbLf' instead of 'vbCrLf'.
TextLines = TextFileToArray(FilePath, vbLf)
If Not IsEmpty(TextLines) Then
' Note that 'Transpose' has a 65536 limit per dimension.
Range("A1").Resize(UBound(TextLines) + 1).Value _
= Application.Transpose(TextLines)
'Debug.Print Join(TextLines, vbLf)
MsgBox "Found " & UBound(TextLines) + 1 & " lines."
Else
MsgBox "No lines found."
End If
End Sub
' The result is a 0-based 1D array.
Function TextFileToArray( _
ByVal FilePath As String, _
Optional Delimiter As String = vbCrLf) _
As Variant
Const ProcName As String = "TextFileToArray"
On Error GoTo clearError
Dim TextFile As Long
TextFile = FreeFile
Open FilePath For Input Access Read As TextFile
On Error Resume Next
TextFileToArray = Split(Input(LOF(TextFile), TextFile), Delimiter)
On Error GoTo clearError
Close TextFile
ProcExit:
Exit Function
clearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
The easiest way is to use a Scripting.Dictionary and the FileSystemObject.
Public Function GetAsStrings(ByVal ipPath As String) As Variant
Dim myFso As Scripting.FileSystemObject
Set myFso = New Scripting.FileSystemObject
Dim myfile As TextStream
Set myfile = myFso.OpenTextFile(ipPath, Scripting.IOMode.ForReading)
Dim myStrings As Scripting.Dictionary
Set myStrings = New Scripting.DIctionary
Do Until myfile.AtEndOfStream
myStrings.Add mystrings.count, myfile.ReadLine
Loop
myfile.Close
Set GetAsStrings = myStrings.Items
End Function
I am using a vba macro to find a big string in a text file.
For that I read the text file , read the text to compare (which is saved in one of the cell). After that i would replace CRLF with CR (since the saved text does not contain CRLF). Then compare. Its working fine if the file size is less. But throwing the error when the file size is high (Around 50 KB is fine).
Any guess about the maximum size of the file?
The below part of the code is throwing error
Open LogFilePath For Input As #iFile
strFileContent = Input(LOF(iFile), iFile)
Close #iFile
strFileContent = Application.WorksheetFunction.Substitute(strFileContent, vbCrLf, "")
strSearch = Application.WorksheetFunction.Substitute(strSearch, vbLf, "")
strFileContent = Application.WorksheetFunction.Substitute(strFileContent, vbTab, " ")
If InStr(1, strFileContent, strSearch, vbBinaryCompare) > 0 Then
SearchTextFile = "success"
Else
SearchTextFile = "failed"
End If
Any guess or suggestion please.
I note the error refers to the Substitute property and that you are using Application.WorksheetFunction.Substitute.
Personally, in VBA I always tend to use the REPLACE function which works in the same way.
I also use this when processing some large .txt files (20,000 rows/30MB) and don't encounter problems with it.
The Substitute is more for use e.g. with a cell formula. You should try following code snippet using Replace for your needs.
Private Sub CommandButton1_Click()
Dim LogFilePath As String
Dim ifile As Integer
ifile = 1
LogFilePath = "D:/_working/application-log-file-small.txt"
strSearch = "Temp Path :"
Open LogFilePath For Input As #ifile
strFileContent = Input(LOF(ifile), ifile)
Close #ifile
'--- Show len of file content string -----
MsgBox (Len(strFileContent))
strFileContent = Replace(strFileContent, vbCrLf, "")
strSearch = Replace(strSearch, vbLf, "")
strFileContent = Replace(strFileContent, vbTab, " ")
If InStr(1, strFileContent, strSearch, vbBinaryCompare) > 0 Then
SearchTextFile = "success"
MsgBox ("success")
Else
SearchTextFile = "failed"
MsgBox ("failed")
End If
End Sub
I have the following code where I am trying to modify some Txt files in a specific folder. I first want to check that the Loop works. However when I run the macro the code can only read the first file and then there is a runtime 5 error at strFileName = Dir(). I am not sure what the problem is. The only issue I can think of is that I am moving the code between two module sheets. The folder location is being saved in a txt box in Sheet 1 of an excel workbook.
Sub Txt_File_Loop()
Public TextFile As String
Dim FolderLocation As String
Dim strFielName As String
Dim SaveLocation As String
'Location is present in a Text box
FolderLocation = Sheets(1).FolderLocationTXTBX.Text
strFileName = Dir(FolderLocation & " \ * ")
Do Until strFileName = ""
TextFile = FolderLocation & "\" & strFileName
Module2.Macro1
strFileName = Dir() 'ERROR is Here
Loop
End Sub
Sub Macro1()
Dim x As String
Open TextFile For Input As #1
Do Until EOF(1)
Line Input #1, textline
x = x & textline
Loop
Close #1
MsgBox x
End Sub
Have a look at these modifications. They seem to correct several things and run through well.
Option Explicit
Sub Txt_File_Loop()
Dim FolderLocation As String
Dim strFileName As String
Dim SaveLocation As String
'Location is present in a Text box
FolderLocation = Sheets(1).FolderLocationTXTBX.Text 'Environ("TMP")
strFileName = Dir(FolderLocation & "\*.txt")
Do Until strFileName = ""
Debug.Print FolderLocation & "\" & strFileName
Module2.Macro1 FolderLocation & "\" & strFileName
strFileName = Dir() 'ERROR is Here
Loop
End Sub
Sub Macro1(sFPFN As String)
Dim x As String, textline As String
Debug.Print sFPFN
Open sFPFN For Input As #1
Do Until EOF(1)
Line Input #1, textline
x = x & textline
Loop
Close #1
MsgBox x
End Sub
I passed the folder and filename name across as a string-type parameter. Also, I don't know why you had the extra spaces in (FolderLocation & " \ * " ; I tightened that up. There were a few misspellings and undeclared variables; these can be avoided with Option Explicit¹ at the top of the module code sheet. Get into the practise of standard indentation with your code. It certainly improves readability if nothing else.
¹ Setting Require Variable Declaration within the VBE's Tools ► Options ► Editor property page will put the Option Explicit statement at the top of each newly created code sheet. This will avoid silly coding mistakes like misspellings as well as influencing you to use the correct variable type in the variable declaration. Variables created on-the-fly without declaration are all of the variant/object type. Using Option Explicit is widely considered 'best practice'.
I read an Excel spreadsheet row by row and for each row create a textfile including information from the columns.
From time to time there is foreign text in some of the spreadsheet cells. In the debugger the foreign text appears as '?' question marks. It fails when trying to write these question marks to the text file.
This is a snippet of the code that reads the values from a row to a string array
Set oFS = CreateObject("Scripting.Filesystemobject")
For Each rID In oSh.UsedRange.Columns("A").Cells
For Each rValue In oSh.UsedRange.Rows(rowCount).Cells
ReDim Preserve columnValues(columnCount)
columnValues(columnCount) = rValue
columnCount = columnCount + 1
Next
Next
This is the code which writes to a text file
sFNText = sMakeFolder & "\" & rID.Value & ".txt"
Set oTxt = oFS.OpenTextFile(sFNText, 2, True)
For i = 0 To UBound(columnTitles)
oTxt.Write columnTitles(i) & ": " & columnValues(i) & vbNewLine
Next i
oTxt.Close
I have experimented with changing the format of opentextfile and also using AscW and ChrW to convert to and from ansi.
EDIT: In particular I am trying to read in Greek symbols (pi, omega etc.) and write them back out to a textfile. I have used the
StrConv(Cells(1, 1), vbUnicode)
method that was detailed in How can I create text files with special characters in their filenames and have got that example working. It seems now a problem with writing this to a textfile. nixda's example seems to work in isolation when using his Print command, however when I try
otxt.Write
to write my stored variable to a textfile it writes out garbage, as opposed to the print method which produces the correct result. Looking at the debugger both variables are stored identically (print method + write), so I believe it is now down to the output method (otxt.Write) which is converting the stored variable into garbage. I have tried using the -1 & -2 options for OpenTextFile - both producing garbage results.
I have the following sheet:
and the following code:
Sub writeUnicodeText()
Dim arr_Strings() As String
i = 0
For Each oCell In ActiveSheet.Range("A1:A4")
ReDim Preserve arr_Strings(i)
arr_Strings(i) = oCell.Value
i = i + 1
Next
Set oFS = CreateObject("Scripting.Filesystemobject")
Set oTxt = oFS.OpenTextFile("C:\users\axel\documents\test.txt", 2, True, -1)
For i = 0 To UBound(arr_Strings)
oTxt.Write arr_Strings(i) & vbNewLine
Next i
oTxt.Close
End Sub
This produces the following file:
This is the code I use to write to a text. I've tried many methods and this has worked the best.
Sub ProcessX()
FName1 = "Location of File"
txtStrngX = OpenTextFileToString2(FName1)
end sub
Public Function OpenTextFileToString2(ByVal strFile As String) As String
Dim hFile As Long
hFile = FreeFile
Open strFile For Input As #hFile
OpenTextFileToString2 = Input$(LOF(hFile), hFile)
Close #hFile
End Function
As for reading in from rows just be sure to set your variable to a string when compiling and any method should work fine.
sorry. That's reading from a text. Here is writing.
Public Function RecordsetToText(rs As Object, Optional FullPath _
As String, Optional ValueDelimiter As String = " ") As Boolean
'PURPOSE: EXPORTS DATA FROM AN ADO RECORDSET TO A TEXT FILE
'PARAMETERS:
'RS: Recordset to Export. Open the recordset before
'passing it to this function
'FullPath (Optional): FullPath of text file.
'if not specified, the function uses app.path +
'rs.txt
'ValueDelmiter (Optional): String to delimiter
'values within a row. If not specified, an tab
'is used
'RETURNS: True if successful, false if an error occurs
'COMMENTS: Rows are delimited by a carriage return
Dim sFullPath As String
Dim sDelimiter As String
Dim iFileNum As Integer
Dim lFieldCount As Long
Dim lCtr As Long
Dim oField As ADODB.Field
On Error GoTo ErrorHandler:
If RecordSetReady(rs) = False Then Exit Function
sDelimiter = ValueDelimiter
If FullPath = "" Then
sFullPath = App.Path
If Right(sFullPath, 1) <> "\" Then sFullPath = _
sFullPath & "\"
sFullPath = sFullPath & "rs.txt"
Else
sFullPath = FullPath
End If
iFileNum = FreeFile
Open sFullPath For Output As #iFileNum
With rs
lFieldCount = .Fields.Count - 1
On Error Resume Next
.MoveFirst
On Error GoTo ErrorHandler
For lCtr = 0 To lFieldCount
Set oField = .Fields(lCtr)
If lCtr < lFieldCount Then
Print #iFileNum, oField.Name & sDelimiter;
Else
Print #iFileNum, oField.Name
End If
Next
Do While Not .EOF
For lCtr = 0 To lFieldCount
Set oField = .Fields(lCtr)
If lCtr < lFieldCount Then
Print #iFileNum, oField.Value & sDelimiter;
Else
Print #iFileNum, oField.Value
End If
Next
.MoveNext
Loop
End With
RecordsetToText = True
ErrorHandler:
On Error Resume Next
Close #iFileNum
End Function
I've been wracking my brains with a file input problem, I've finally got it down to two problems, I can get past the error 62, "Read past End of file", but this one I can't get past.
Can someone tell me if I'm doing anything wrong / verify?
Basically the (this) code writes two lines#
?xml version="1.0"?
A Second Line
the debug statement in Part 1 (write file) prints the text as
?xml version="1.0"?
A Second Line
the debug statement in Part 2 (read file) prints the text as
ÿþ?xml version="1.0"?
A Second Line
As you can see, there are two extra characters being added to the either the input or
the output stream at the beginning of the file.
A second line has been added for completeness to show in more detail that it is only the first line that is being screwed.
When I look through Notepad there is nothing extra, what/where are these extras coming from?
Any thoughts, thanks in advance,
regards
Seán
Sub writeXMLTest()
'Part 1 - Write the file
Dim FSO As Object
Dim NewFile As Object
Dim FullPath As String
Dim XMLFileText As String
FullPath = "E:\TESTFILE.xml"
'On Error GoTo Err:
Set FSO = CreateObject("Scripting.FileSystemObject")
Set NewFile = FSO.CreateTextFile(FullPath, 1, 1)
XMLFileText = ""
XMLFileText = XMLFileText & "?xml version=" & Chr(34) & "1.0" & Chr(34) & "?" & vbNewLine
NewFile.Write (XMLFileText)
Debug.Print XMLFileText
XMLFileText = XMLFileText & "A Second Line" & vbNewLine
NewFile.Write (XMLFileText)
Debug.Print XMLFileText
NewFile.Close
'Part 1 - Complete
'Part 2 - Now to read the file
Dim FileNum As Integer, i As Integer
Dim s As String
' fpath = Application.GetOpenFilename
FileNum = FreeFile()
Open FullPath For Input As #FileNum
i = 1
While Not EOF(FileNum)
Line Input #FileNum, s ' read in data 1 line at a time
Debug.Print s
Wend
End Sub
Just a quick shot: Generally, xml-files use UTF8 encoding. But the FileSystemObject cannot handle UTF8. You can do this (read and write UTF8-Files in VBA) with an ADODB.Stream object - you'll find examples across the web.