I have multiple .csv files that I need to find the length of in my directory. (The number of rows that have data in them.) I'm running the following code from a .xlsx file in the same directory. (I intend to copy data from the .csv files to the .xlsx file eventually.)
i = 1
FilePath = Application.ActiveWorkbook.Path & "\"
file = Dir(FilePath & "*.csv")
Do While Len(file) > 0
Open FilePath & file For Input As #1
length(i) = Cells(Rows.Count, 1).End(xlUp).Row
i = i + 1
Close #1
file = Dir
Loop
All the values of the length array end up being 1, even though the .csv files are probably 15-20 rows long.
You're not actually opening the file in Excel so you can't count how many cells there are. Try reading how many lines instead:
Open FilePath & file For Input As #1
While Not EOF(1): Line Input #1, trashLine: Wend
i = i + 1
Close #1
Alternatively, open the file in Excel - test - then close afterwards:
Set tempWB = Workbooks.Open(FilePath & file)
i = i + tempWB.Sheets(1).Cells(tempWB.Sheets(1).Rows.Count, 1).End(xlUp).Row
tempWB.Close False
Or an even quicker way is to use Windows Script:
Dim i As Long
For Each varFile In _
Filter(Split(CreateObject("WScript.Shell").Exec("cmd /c find /v /c """" """ _
& ThisWorkbook.Path & "\*.csv""").StdOut.ReadAll, vbCrLf), ":")
i = i + CLng(Split(varFile, ":")(2))
Next
Debug.Print i
That way, if you've got 10 files the code is only working with 10 strings rather than opening/closing a file or reading thousands of lines...
As #SOofWXLS stated, your code is not opening the files in Excel, you are opening them for direct i/o.
Here is a complete code sample that will fill your array with the file lengths as you were trying to do.
Dim fPath As String
Dim fName As String
Dim hFile As Long
Dim i As Long
Dim NumLines As Long
Dim length() As Long
Dim strLine As String
ReDim length(1 To 1)
fPath = Application.ActiveWorkbook.Path & "\"
fName = Dir(fPath & "*.csv")
Do While Len(fName) > 0
i = i + 1
NumLines = 0
ReDim Preserve length(1 To i)
hFile = FreeFile
Open fPath & fName For Input As hFile
Do While Not EOF(hFile)
Line Input #hFile, strLine
NumLines = NumLines + 1
Loop
Close hFile
length(i) = NumLines
fName = Dir
Loop
This will also dynamically expand your array to accommodate as many files as are found.
Related
I have 100's of text files named correctly, but I need the name of the text file added into the first row (thus shifting the existing data down to the second row) with " on either side of the name.
The text files are over multiple folders, so I need to be able to open an explorer dialogue first to select multiple text files and add the new header row to every one.
Any help would be hugely appreciated as I cannot find the answer anywhere on google!
Tom
My attempt, but doesnt really work becaue 1. I have to set the directory, and 2. I need to have the filename with " either side, for example "Line1":
Sub ChangeRlnName()
'the final string to print in the text file
Dim strData As String
'each line in the original text file
Dim strLine As String
Dim time_date As String
Set FSO = CreateObject("Scripting.FileSystemObject")
'Get File Name
Filename = FSO.GetFileName("C:\Users\eflsensurv\Desktop\Tom\1.txt")
'Get File Name no Extension
FileNameWOExt = Left(Filename, InStr(Filename, ".") - 1)
strData = ""
time_date = Format(Date, "yyyymmdd")
'open the original text file to read the lines
Open "C:\Users\eflsensurv\Desktop\Tom\1.txt" For Input As #1
'continue until the end of the file
While EOF(1) = False
'read the current line of text
Line Input #1, strLine
'add the current line to strData
strData = strData + strLine & vbCrLf
Wend
'add the new line
strData = FileNameWOExt + vbLf + strData
Close #1
'reopen the file for output
Open "C:\Users\eflsensurv\Desktop\Tom\1.txt" For Output As #1
Print #1, strData
Close #1
End Sub
Try something like this:
Sub Tester()
Dim colFiles As Collection, f
'get all txt files under specified folder
Set colFiles = GetMatches("C:\Temp\SO", "*.txt")
'loop files and add the filename as a header
For Each f In colFiles
AddFilenameHeader CStr(f)
Next f
End Sub
Sub AddFilenameHeader(fpath As String)
Dim base, content
With CreateObject("scripting.filesystemobject")
base = .GetBaseName(fpath) 'no extension
With .OpenTextFile(fpath, 1)
'get any existing content
If Not .AtEndOfStream Then content = .readall()
.Close
End With
DoEvents
'overwrite existing content with header and previous content
.OpenTextFile(fpath, 2, True).write """" & base & """" & vbCrLf & content
End With
End Sub
'Return a collection of file paths given a starting folder and a file pattern
' e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function GetMatches(startFolder As String, filePattern As String, _
Optional subFolders As Boolean = True) As Collection
Dim fso, fldr, f, subFldr, fpath
Dim colFiles As New Collection
Dim colSub As New Collection
Set fso = CreateObject("scripting.filesystemobject")
colSub.Add startFolder
Do While colSub.Count > 0
Set fldr = fso.getfolder(colSub(1))
colSub.Remove 1
If subFolders Then
For Each subFldr In fldr.subFolders
colSub.Add subFldr.Path
Next subFldr
End If
fpath = fldr.Path
If Right(fpath, 1) <> "\" Then fpath = fpath & "\"
f = Dir(fpath & filePattern) 'Dir is faster...
Do While Len(f) > 0
colFiles.Add fpath & f
f = Dir()
Loop
Loop
Set GetMatches = colFiles
End Function
I am trying to replace characters such as "/" and "ó", and also a line break (alt + ENTER, manually replaced in excel with find and replace with CTRL + J) in excel files (.xlsx). The characters can be found all over the excel sheets (not one particular range). The reason that I would like to replace these values is that these characters are giving me errors in another application.
I have 20 excel files in one folder, with multiple sheets. I would like to make a script (vba macro) to loop through the excel files and all its sheets and do the replacements.
I am very new with vba/macros.
Sub ReplaceStringInFile()
Dim sBuf As String
Dim sTemp As String
Dim sFileName As String
Dim FileExt(2) As String
ChDir = "C:\mydirectory\"
FileExt(1) = "xlsx"
For i = 1 To 1
sFileName = Dir("*." & FileExt(i))
Do
If sFileName = "" Then Exit Do
sTemp = ""
Open sFileName For Input As #1
Do Until EOF(1)
Line Input #1, sBuf
sTemp = sTemp & sBuf & vbCrLf
Loop
Close #1
sTemp = Replace(sTemp, "ó", "o")
sTemp = Replace(sTemp, "/", "")
Open sFileName For Output As #1
Print #1, sTemp
Close #1
sFileName = Dir()
Loop
Next i
End Sub
I have tried to combine code from scripts mentioned here:
Find and replace string in all excel files in folder and here
Excel macro to find and replace multiple strings in any text file
Loop through files in a folder using VBA?
But I didn't get it to work.
Help would be very appreciated!
My code isn't working, and i couldnt seem to find a solution in already asked questions.
I want to paste in data to the CSV file, but it doesnt seem to be able to find it.
It bugs at
outputFile.Cells(i, 2) = 1949.5 + (Worksheets("Base").Cells(i, 5) / 2)
which is where i locate the data. Is anybody able to see what's wrong?
Sub works()
Dim outputFile 'Pointer to the file
Dim outputFileName 'Filename of the export file
Dim outputPath 'Path for the file
Dim numRows
Dim currentRow
Dim writeFile
Dim fileExists
writeFile = vbYes
outputFile = FreeFile
outputFileName = "AdminExport.csv"
outputPath = Application.ActiveWorkbook.Path
fileExists = Dir(outputPath & Application.PathSeparator & outputFileName)
If (fileExists <> "") Then
writeFile = MsgBox("File already exists at the moment!" & vbCrLf & "Do you want to overwrite it with a new one?", vbYesNo + vbCritical)
End If
If (writeFile = vbYes) Then
Open outputPath & Application.PathSeparator & outputFileName For Output Lock Write As #outputFile
'Lock write = VBA har fuld rettighed til dokumentet (Ekslusivt)
For i = 2 To 18288
If Left(Worksheets("Base").Cells(i, 12), 6) = "262015" Then
outputFile.Cells(i, 2) = 1949.5 + (Worksheets("Base").Cells(i, 5) / 2)
End If
Next i
Print #outputFile, "Person_ID;STUDENT_ID_OLD;STUDENT_ID_NEW;ENROLL_PERIOD"
'Overskrifter i CSV-filen
numRows = Worksheets("Base").Range("A1").End(xlDown).Row
For currentRow = 2 To numRows
'Tæller antal rækker i "Base"
Print #outputFile, Worksheets("Base").Range("A" & currentRow) & ";" & Worksheets("Base").Range("B" & currentRow)
Next
End If
Close outputFile
'Lukker den, da vi har 'open' oppe over
End Sub
The problem is with this part of the code in the line you're getting the error:
outputFile.Cells(i, 2)
You cannot reference cells the same way as in Excel when writing to binary files. You need to use the print statement instead for that. See this tutorial.
how do i auto rename multiple files that are being copied with different indexing? i mean the (0), (1), etc... i.e. if i have two files in Folder1 that has a.txt and b.txt, And another two same files inside the Folder2 And copy the a.txt and b.txt from Folder1 to Folder2 then the a.txt will become a(1).txt and the b.txt to b(1).txt. how do i do it in a single instance? what came to my mind is to have many Strings and Integers as many as the files, but i will be dealing thousands of files. This is what i have so far.
Dim ii as Integer = 0
Dim iii as Integer = 0
Sub Copy()
For i = 0 To updatedFiles.Count - 1
Dim fileName As String = Path.GetFileNameWithoutExtension(updatedFiles(i))
Dim filePath As String = Path.GetDirectoryName(updatedFiles(i))
Dim fileExt As String = Path.GetExtension(updatedFiles(i))
Dim newFile As String = filePath & "\" & fileName & "(" & ii & ")" & fileExt
Dim newFile2 As String = filePath & "\" & fileName & "(" & iii & ")" & fileExt
If File.Exists(Path.Combine(dest, updatedFiles(i))) Then
ii += 1
'Copy newFile
ElseIf File.Exists(Path.Combine(dest, newFile)) Then
iii += 1
'Copy newFile2
End If
Next
End Sub
This doesn't do it right, from the situation above, the a.txt becomes a(1).txt but the b.txt becomes b(2).txt. the result should be
a (1).txt
b (1).txt
You will need to have: Imports System.IO
When Copy() is run, all of the files from the source folder will be copied over to the destination folder, and renamed file(1).ext, file(2).ext, etc. if the file already exists in the destination folder:
Dim sourceFolder As String = "C:\Users\Public\Documents\Folder1"
Dim destFolder As String = "C:\Users\Public\Documents\Folder2"
Sub Copy()
Dim allFiles() As String 'Put all files in an array
allFiles = Directory.GetFiles(sourceFolder)
Dim i As Integer = 0 'File counter
Dim fileName As String = "" 'This will be name of file without path
Dim fileNameNoExt As String = "" 'Name of file without extension
Dim fileExt As String = "" 'File Extension
For j As Integer = 0 To allFiles.Count - 1
i = 1 're-initialize i
fileName = allFiles(j).Substring(allFiles(j).LastIndexOf("\") + 1)
fileNameNoExt = allFiles(j).Substring(allFiles(j).LastIndexOf("\"), allFiles(i).LastIndexOf(".") - allFiles(j).LastIndexOf("\"))
fileExt = allFiles(j).Substring(allFiles(j).LastIndexOf(".") + 1)
If File.Exists(destFolder & "\" & fileName) Then
While File.Exists(destFolder & "\" & fileNameNoExt & "(" & i & ")." & fileExt)
i += 1
'when while fails, i will hold the next value for file
End While
File.Copy(allFiles(j), destFolder & "\" & fileNameNoExt & "(" & i & ")." & fileExt)
Else
File.Copy(allFiles(j), destFolder & "\" & fileName)
'if there is no file with the same name, there is a direct copy of the file to the destination folder
End If
Next
End Sub
Easiest way is iterate twice. Once to add something to the name like aTBR.txt, bTBR.txt. TBR(To be renamed). You can put anything.
Second time to change name to what you would like it to be.
Harder way but maybe faster is to start with renaming last object. d.txt to e.txt?? then c.txt to d.txt, b.txt to c.txt
For that option you would need to keep their names in order in some array, or have them in alphabetic order and store their names array when you load app.
Update:
put Dim ii as Integer = 0
Dim iii as Integer = 0
inside for loop
Filename = Dir(Filepath & "\" & "*.csv")
While Filename <> ""
SourceFile = Filepath & "\" & Filename
TargetFile = SavePath & "\" & Replace(Filename, ".csv", ".txt")
OpenAsUnicode = False
Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
'Detect Unicode Files
Dim Stream: Set Stream = objFSO.OpenTextFile(SourceFile, 1, False)
intChar1 = Asc(Stream.Read(1))
intChar2 = Asc(Stream.Read(1))
Stream.Close
If intChar1 = 255 And intChar2 = 254 Then
OpenAsUnicode = True
End If
'Get script content
Set Stream = objFSO.OpenTextFile(SourceFile, 1, 0, OpenAsUnicode)
arrData = Stream.ReadAll()
Stream.Close
'Create output file
Dim objOut: Set objOut = objFSO.CreateTextFile(TargetFile)
objOut.Write Replace(Replace(arrData,",", "#|#"), Chr(34), "") '-- This line is working fine but it is replacing all the commas inside the text qualifier as well..
objOut.Close
Filename = Dir
Wend
In the above code the line objOut.Write Replace(Replace(arrData,",", "#|#"), Chr(34), "") is replacing all the commas with #|# including the commas inside string.so I want to replace only commas which are not in double quotes.
File containing the string
"A","B,C",D
Result I need is
A#|#B,C#|#D
Thanks for your help in advance.
How about something along the line of:
objOut.Write Mid(Replace(Replace(arrData,""",""", "#|#"), Chr(34), ""), 2)
Basically, this exchanges now "," for #|#. But that's not enough as the file begins with a ". So, this one is being eliminated using the Mid() function. If the file also ends with a " then you would have to adjust that as well.
Based on the speed concerns noted in the comments here is the complete code which I used to test this solution:
Option Explicit
Option Compare Text
Public Sub ConvertFile()
Dim lngRowNumber As Long
Dim strLineFromFile As String
Dim strSourceFile As String
Dim strDestinationFile As String
strSourceFile = "C:\tmp\Extract.txt"
strDestinationFile = "C:\tmp\Extract_b.txt"
Open strSourceFile For Input As #1
Open strDestinationFile For Output As #2
lngRowNumber = 0
Do Until EOF(1)
Line Input #1, strLineFromFile
strLineFromFile = Mid(Replace(strLineFromFile, """,""", "#|#"), 2)
Write #2, strLineFromFile
strLineFromFile = vbNullString
Loop
Close #1
Close #2
End Sub
The tested file was 350 MB with a bit over 4 million rows. The code completed in less than a minute.