Background
I need to open multiple csvs in multiple folders, and for this matter I use FreeFile as input: let's say there are over 1000 csvs (powerquery will not have use here, since I only need the last row of data of each csv and then analyze that). I have seen that expanding to 512 may temporarily fix it in a way, but I do not think that is the core cause, hence, not providing a long term solution.
Problem
Seems like even if I close the file, the memory is not properly cleared, hence I get an error 67 after some looping on files has been done.
Code
I created a function to retrieve the Last Line within my main sub code, I even attempted to loop until freefile is 1 again (I added some sleep as well), but no luck, at some point, grows at 2.
Function Return_VarInCSVLine(ByRef NumLineToReturnTo As Long, ByRef TxtFilePathCSV As String, Optional ByRef IsLastLine As Boolean) As Variant
If NumLineToReturnTo = 0 Then NumLineToReturnTo = 1
'NumLineToReturnTo has to be at least 1 even if LastLine is set to true so no error is arised from IIF
Dim NumFileInMemory As Long
Dim ArrVarTxtLines() As Variant
Dim CounterArrTxtLines As Long
Dim TxtInLine As String
NumFileInMemory = FreeFile: CounterArrTxtLines = 1
Open TxtFilePathCSV For Input As #NumFileInMemory: DoEvents
Do While Not EOF(NumFileInMemory)
Line Input #NumFileInMemory, TxtInLine
ReDim Preserve ArrVarTxtLines(1 To CounterArrTxtLines)
ArrVarTxtLines(CounterArrTxtLines) = TxtInLine
CounterArrTxtLines = CounterArrTxtLines + 1
Loop
LoopUntilClosed:
Close #NumFileInMemory: Sleep (10): DoEvents
NumFileInMemory = FreeFile
If NumFileInMemory > 1 Then GoTo LoopUntilClosed
Return_VarInCSVLine = IIf(IsLastLine = True, ArrVarTxtLines(UBound(ArrVarTxtLines)), ArrVarTxtLines(NumLineToReturnTo))
End Function
Question
How can I avoid this error in this scenario? Or what are my alternatives? I used to do workbooks.Open but that is slower than just using FreeFile and then Open for input
You could try to use the FileSystemObject on a Windows PC
Function fsoReadLine(fileName As String, lineNo As Long, Optional lastLine As Boolean) As String
Dim fso As Object
Dim textFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set textFile = fso.OpenTextFile(fileName, 1)
Dim vDat As Variant
' Read the whole file and split it by lines
vDat = Split(textFile.ReadAll, vbCrLf)
Dim totalLines As Long
totalLines = UBound(vDat) + 1 ' zero based array!
If lastLine Then
fsoReadLine = vDat(totalLines - 1)
Else
If lineNo <= totalLines Then
fsoReadLine = vDat(lineNo - 1)
End If
End If
textFile.Close
End Function
And if you only need the last line you could shorten the code to
Function fsoLastLine(fileName As String) As String
Dim fso As Object
Dim textFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set textFile = fso.OpenTextFile(fileName, 1)
Dim vDat As Variant
' Read the whole file and split it by lines
vDat = Split(textFile.ReadAll, vbCrLf)
fsoLastLine = vDat(UBound(vDat))
textFile.Close
End Function
Related
I want to delete the record from CSV after reading that row. Please guide me how can I achieve this.
I have found this piece of code :
Sub ImportCSVFile(ByVal filePath As String, ByVal ImportToRow As Integer, ByVal StartColumn As Integer)
Dim line As String
Dim arrayOfElements
Dim element As Variant
Open filePath For Input As #1 ' Open file for input
Do While Not EOF(1) ' Loop until end of file
Line Input #1, line
Debug.Print line
arrayOfElements = Split(line, ";") 'Split the line into the array.
Loop
Close #1 ' Close file.
End Sub
It is reading the CSV file and working as required. Can someone please advise that how can I delete the row in CSV file after reading it ?
If I were to be doing this I would use a FileSystemObject to read a line rather than opening the file directly. I am not sure what it is you want to do for editing the log file itself but I you want to loop through each line and then through each token the code I would use is:
Sub ImportCSVFile(ByVal filePath As String, Optional ByVal ImportToRow As Long = 0, Optional ByVal StartColumn As Long = 1)
'Declare variables.
Dim FSO As Object, sourceFile As Object
Dim line As String, delimiter As String, ForReading As Integer: ForReading = 1
Dim i As Long: i = 1
Dim arrayOfElements As Variant, element As Variant
'Create file system object and open filePath .csv parameter.
Set FSO = CreateObject("Scripting.FileSystemObject")
Set sourceFile = FSO.OpenTextFile(filePath)
delimiter = ";"
'Main loop, reads each line of the .csv file.
Do While Not sourceFile.AtEndOfStream
'Checks if the line being read is at or after the StartColumn parameter.
If i >= StartColumn Then
'Splits line string into an array based on the delimiter.
line = sourceFile.ReadLine
arrayOfElements = Split(line, delimiter)
'Loops through array elements.
For Each element In arrayOfElements
'Your code here.
Next element
End If
'If a value for ImportToRow is provided checks if that line has been reached.
If Not ImportToRow = 0 Then
If i >= ImportToRow Then
Exit Do
End If
End If
i = i + 1: Loop
'Cleans up objects.
Set sourceFile = Nothing: Set FSO = Nothing
End Sub
I feel dirty asking this because it's such a hacky workaround, but I have a project where the deliverable must be a single .xlsm file. However, we have no restrictions on what files that deliverable may write or execute. VBA and Excel's macro editor have limitations that don't work with the project.
So I'm trying to save the binary values of a Python interpreter in a worksheet and then write that .exe to the client's computer when the macro is run. (It's pretty much a virus and a bad idea, I know, but the requirements are strict and unchangeable.)
I have a macro to read python.exe into a worksheet:
Function ReadFromFile(path)
Dim bytes() As Byte
Dim fileInt As Integer: fileInt = FreeFile
Open path For Binary Access Read As #fileInt
ReDim bytes(0 To LOF(fileInt) - 1)
Get #fileInt, , bytes
Close #fileInt
Set ReadFromFile = bytes
End Function
Sub ReadCompiler_Click()
Dim path As String: path = ActiveWorkbook.path & "\python.exe.original"
Dim bytes() As Byte
bytes = ReadFromFile(path)
Dim cell As Range
Set cell = Worksheets("PythonEXE").Range("A1")
For Each chunk In bytes
cell.Value = chunk
Set cell = cell.Offset(1, 0)
Next chunk
End Sub
I have verified that this copies the binary file byte-for-byte into column A of my PythonEXE worksheet.
My problem is when writing the bytes back to a file, the written file is significantly different than the original. I'm using the following functions to write from the worksheet to the output file:
Function WriteToFile(path, data)
Dim fileNo As Integer
fileNo = FreeFile
Open path For Binary Access Write As #fileNo
Put #fileNo, 1, data
Close #fileNo
End Function
Sub WriteCompiler_Click()
Dim TotalRows As Long
Dim bytes() As Byte
TotalRows = Worksheets("PythonEXE").Rows(Worksheets("PythonEXE").Rows.Count).End(xlUp).Row
ReDim bytes(TotalRows)
For i = 1 To TotalRows
bytes(i) = CByte(Worksheets("PythonEXE").Cells(i, 1).Value)
Next i
Dim path As String: path = ActiveWorkbook.path & "\python.exe.written"
WriteToFile path, bytes
End Sub
Why is my output binary different than the input binary? It's not human readable, but their checksums are different and when I open them both in an IDE the output file looks like it has a bunch of rectangle glyphs at the beginning where the input file does not.
I changed a couple of things (guided by this answer to get around the problem:
When VBA writes a Variant, it puts some header info in the output. So I changed WriteToFile to copy data to a Byte array before writing it:
Dim buffer() As Byte
ReDim buffer(UBound(data))
buffer = data
For i = 0 To UBound(data)
Put #fileNo, i + 1, CByte(buffer(i))
Next i
I had an off-by-one error by going to UBound(data) instead of UBound(data) - 1. This is a little hairy because Put takes the write position as one-based instead of zero-based, but array indexers are zero-based:
Dim buffer() As Byte
ReDim buffer(UBound(data))
buffer = data
For i = 0 To (UBound(data) - 1)
Put #fileNo, i + 1, CByte(buffer(i))
Next i
Here's the full solution:
Function WriteToFile(path, data)
Dim fileNo As Integer
fileNo = FreeFile
Open path For Binary Access Write As #fileNo
Dim buffer() As Byte
ReDim buffer(UBound(data))
buffer = data
For i = 0 To (UBound(data) - 1)
Put #fileNo, i + 1, CByte(buffer(i))
Next i
Close #fileNo
' Shell ("explorer.exe " & path)
End Function
Function ReadFromFile(path)
Application.StatusBar = "Reading " & path
Dim bytes() As Byte
Dim fileInt As Integer: fileInt = FreeFile
Open path For Binary Access Read As #fileInt
ReDim bytes(0 To LOF(fileInt) - 1)
Get #fileInt, , bytes
Close #fileInt
ReadFromFile = bytes
End Function
Sub UpdatePython_Click()
Application.Calculation = xlCalculationManual
Dim path As String: path = ActiveWorkbook.path & "\python.exe.original"
Dim bytes() As Byte
bytes = ReadFromFile(path)
Worksheets("PythonEXE").Columns(1).EntireColumn.Clear
Dim cell As range
Set cell = Worksheets("PythonEXE").range("A1")
For Each chunk In bytes
cell.Value = chunk
Set cell = cell.Offset(1, 0)
Next chunk
Application.ActiveWorkbook.Save
Application.Calculation = xlCalculationAutomatic
End Sub
Sub WriteCompiler_Click()
Dim TotalRows As Long
Dim bytes() As Byte
TotalRows = Worksheets("PythonEXE").Rows(Worksheets("PythonEXE").Rows.Count).End(xlUp).Row
ReDim bytes(TotalRows)
For i = 0 To TotalRows
bytes(i) = CByte(Worksheets("PythonEXE").Cells(i + 1, 1).Value)
Next i
Dim path As String: path = ActiveWorkbook.path & "\python.exe.written"
If Dir(path) <> "" Then
Kill path
End If
WriteToFile path, bytes
Shell ActiveWorkbook.path & "\checksum.bat", vbNormalFocus
End Sub
I am writing a makro to read thousands of big text files, analyse their content and save a desired part of its content into my Excel worksheet.
On another thread it said that the readAll method of a TextStream object is a good way to do so, so I copied a piece of code and built my makro around it.
Every few hundred textfiles though it throws a weird error. The file being processed is being emptied by my makro and the makro stops working.
Again: Before I start the makro the textfile that throws an error has content in it(as far as I can see it looks like any other textfile), but when Excel throws the error the textfile's content is deleted.
Can you think of the reason for this error or suggest an alternative that might now give this error?
Function readFileContent(FILENAME As String) As String
'reads the txt file into a string and deletes parts before the first "<TestFlow" Element`
Dim lngStart As Long
Dim lngLength As Long
Dim fsoMyFile As FileSystemObject
Dim tsTempo As TextStream
Dim StrContent As String
lngStart = 0
lngLength = 0
Set fsoMyFile = New FileSystemObject
Set tsTempo = fsoMyFile.OpenTextFile(FILENAME, ForReading)
StrContent = tsTempo.ReadAll
Set tsTempo = fsoMyFile.OpenTextFile(FILENAME, ForWriting, False, TristateFalse)
tsTempo.Write (StrContent)
'Cut of everything up to the first <TextFlow tag
lngStart = InStr(StrContent, "<TextFlow")
If lngStart = 0 Then
readFileContent = "SKIPPED"
End If
lngLength = Len(StrContent)
StrContent = Right(StrContent, lngLength - lngStart)
readFileContent = StrContent
End Function
The line StrContent = tsTempo.ReadAll is the line where the program stops. I get no error message.
As you use same file name for reading and writing, you should close it after each operation:
Set fsoMyFile = New FileSystemObject
Set tsTempo = fsoMyFile.OpenTextFile(FILENAME, ForReading)
StrContent = tsTempo.ReadAll
tsTempo.Close '// <=== CLOSE
Set tsTempo = fsoMyFile.OpenTextFile(FILENAME, ForWriting, False, TristateFalse)
tsTempo.Write (StrContent)
tsTempo.Close '// <=== CLOSE
I have a (large) column of data stored in a txt file.
I need to copy the column vector in an Excel sheet. Here is my code:
Dim t As Single
t = Timer
Dim sFile As String
inputFile = "C:\Temp\vector.txt"
Dim rowNum As Long
rowNum = 1
Dim dest As Range
Set dest = Sheet1.Cells(rowNum, 1)
Open inputFile For Input As #1
Do Until EOF(1)
Input #1, ReadData
If Not IsEmpty(ReadData) Then
dest.Cells = ReadData
rowNum = rowNum + 1
Set dest = Sheet1.Cells(rowNum, 1)
End If
Loop
Close #1 'close the opened file
Sheet1.[C2].Value = Timer - t
I wonder whether there is a more efficient/fast way to accomplish the same task.
To this aim, does it make sense to convert the txt file into another format (say .csv, .xlsx or any other file type) instead of reading lines from the .txt file?
Any help is highly appreciated.
S
Following this link I have tried different solutions.
The following code provides a much faster solution to the problem (importing in Excel a column of 500,000 random numbers) as compared to the code proposed in the initial question.
Dim t As Single
t = Timer
Dim inputFile As String
inputFile = "C:\Temp\vector.txt"
Dim wbI As Workbook, wbO As Workbook
Dim wsI As Worksheet
Set wbI = ThisWorkbook
Set wsI = wbI.Sheets("Sheet1")
Set wbO = Workbooks.Open(inputFile)
wbO.Sheets(1).Columns(1).Copy wsI.Columns(1)
wbO.Close SaveChanges:=False
Sheet1.[C2].Value = Timer - t
In particular, after 20 trials, the average computational time was 1.50 seconds, while con the first code it was 10.2 seconds.
Hope this helps!
If you want to use the first approach (which I'd recommend as it doesn't involve opening the files through Excel) then you can reduce the run time by batching the prints.
Also you may want to consider using scripting.filesystemobject rather than the older IO interface.
See example below (Note this code hasn't been tested)
const path as string = ""
const max_print_rows as integer = 10000
dim print_start_cell as range
dim print_arr () as string
dim i as integer,j as long
dim fso as scripting.filesystemobject
dim in_file as scripting.textstream
set print_start_cell=thisworkbook.names("Start_Cell").referstorange
set fso=new scripting.filesystemobject
set in_file=fso.opentextfile(path,forreading)
redim print_arr(1 to max_print_rows,1 to 1)
do until in_file.atendofstream
i=i+1
print_arr(i)=in_file.readline
if I=max_print_rows then
print_start_cell.offset(j).resize(max_print_rows).value=print_arr
j=j+i
erase print_arr
redim print_arr(1 to max_print_rows)
i=1
end if
loop
print_start_cell.offset(j).resize(max_print_rows).value=print_arr
erase print_arr
in_file.close
set in_file=nothing
set print_start_cell=nothing
set fso=nothing
Greetings, I'm hoping for help in figuring out how to store each row of a text file read into a VBA program as a string. I want to modify one of the strings and then put them all back together, but do not know how to read through a text file and store each row as a separate variable in an intelligent way. Thanks for any help you can provide!
If you don't want to add references, you could just go with straight vba code.
Take for instance the following file wordlist.txt:
realize
empty
theorize
line
socialize
here
analyze
The following code uses two methods to do as you described (one more common than the other):
Option Explicit
Sub main()
Dim sFileName As String
Dim sMergedLineArray() As String
Dim sTextToFind As String
Dim sReplacementText As String
Dim sOutputFile As String
Const MY_DELIMITER = "|"
sFileName = "C:\deleteme\wordlist.txt"
sMergedLineArray = ReadFileIntoArray(sFileName)
sTextToFind = "ze"
sReplacementText = "se"
'Loop through each value in the array and make a change if you need to
Dim x As Integer
For x = 0 To UBound(sMergedLineArray)
If InStr(1, sMergedLineArray(x), sTextToFind, vbTextCompare) > 0 Then
sMergedLineArray(x) = Replace(sMergedLineArray(x), sTextToFind, sReplacementText, 1, -1, vbTextCompare)
End If
Next x
sOutputFile = "C:\deleteme\UK_Version.txt"
If Not SpitFileOut(sOutputFile, sMergedLineArray) Then
MsgBox "It didn't work :("
End If
'OR...put it all together, make a mass change and split it back out (this seems unlikely, but throwing it in there anyway)
sTextToFind = "se"
sReplacementText = "ze"
Dim sBigString As String
Dim sNewArray As Variant
sBigString = Join(sMergedLineArray, MY_DELIMITER)
sBigString = Replace(sBigString, sTextToFind, sReplacementText, 1, -1, vbTextCompare)
sNewArray = Split(sBigString, MY_DELIMITER, -1, vbTextCompare)
sOutputFile = "C:\deleteme\American_Version.txt"
If Not SpitFileOut(sOutputFile, sNewArray) Then
MsgBox "It didn't work"
End If
MsgBox "Finished!"
End Sub
Function ReadFileIntoArray(sFileName As String) As String()
Dim sText As String
Dim sLocalArray() As String
Dim iFileNum As Integer
Dim iLineCount As Integer
iFileNum = FreeFile
Open sFileName For Input As #iFileNum
Do Until EOF(iFileNum)
Input #iFileNum, sText
ReDim Preserve sLocalArray(iLineCount)
sLocalArray(iLineCount) = sText
iLineCount = iLineCount + 1
Loop
Close #iFileNum
ReadFileIntoArray = sLocalArray
End Function
Function SpitFileOut(sFileName As String, sMyArray As Variant) As Boolean
Dim iFileNum As Integer
Dim iCounter As Integer
SpitFileOut = False
iFileNum = FreeFile
Open sFileName For Output As #iFileNum
For iCounter = 0 To UBound(sMyArray)
Print #iFileNum, sMyArray(iCounter)
Next
Close #iFileNum
SpitFileOut = True
End Function
If you run the main sub, you'll end up with two files:
UK_Version.txt: This is the result of the first method
American_Version.txt: This is the result of the second
There's lesson 1 of VBA, young Padawan; absorb it, learn and change your login name :P
Look into the FileSystemObject (ref: 1, 2, 3)
You have to go to <Tools/References> menu and include the Microsoft Scripting Runtime and create a global variable Global fso as New FileSystemObject. Now anywhere in your code do things like fso.OpenTextFile() which returns a TextStream. Each TextStream has methods loke ReadLine(), ReadAll(), SkipLine(), WriteLine(), etc ...
Here is a quick sample code.
Global fso as New FileSystemObject
Sub TEST()
Dim ts As TextStream
Set ts = fso.OpenTextFile("text_file.txt", ForReading, False)
Dim s As String
s = ts.ReadAll()
End Sub