This question already has answers here:
Recursively access subfolder files inside a folder
(2 answers)
Closed 6 years ago.
So I want to make a .vbs that edits all .txt in a folder. This the code I used, and the folder is C:\test folder.
Const ForReading = 1
Const ForWriting = 2
newline = ""
line = 1
Set objFSO = CreateObject("Scripting.FileSystemObject")
objStartFolder = "C:\test folder\"
Dim lineCount : lineCount = 0
Dim firstContent : firstContent = ""
Set objFolder = objFSO.GetFolder(objStartFolder)
Set colFiles = objFolder.Files
For Each objFile in colFiles
If LCase(objFSO.GetExtensionName(objFile)) = "txt" Then
lineCount = 0
firstContent = ""
FileName = objStartFolder & objFile.Name
Set objStream = objFSO.OpenTextFile(FileName, ForReading)
Do Until objStream.AtEndOfStream
lineCount = lineCount + 1
firstContent = firstContent & objStream.ReadLine & vbCrLf
If lineCount = line Then
firstContent = firstContent & newline & vbCrLf
End If
Loop
Set objStream = objFSO.OpenTextFile(FileName, ForWriting)
objStream.WriteLine firstContent
objStream.Close
End If
Next
It works. and changes all the text files to what I want them to say, but when I made a folder in C:\test folder called SF (C:\test folder\SF), all of the text files in SF don't change. How do I get it to work with subfolders?
Recursion is a function calling itself. It is used to walk trees.
ProcessFolder DirName
Sub ProcessFolder(FolderPath)
' On Error Resume Next
Set fldr = fso.GetFolder(FolderPath)
Set Fls = fldr.files
For Each thing in Fls
msgbox Thing.Name & " " & Thing.path
Next
Set fldrs = fldr.subfolders
For Each thing in fldrs
ProcessFolder thing.path
Next
End Sub
Related
I am trying to add a Do While loop to also output the number of rows in each file found in the folder specified. I am having trouble with it - I keep getting 0 rows with all versions of my code. Below is the original without the row count addition. I am hitting a wall and would love some direction.
Sub ListAllFilesInAllFolders()
Dim MyPath As String, MyFolderName As String, MyFileName As String
Dim i As Integer, F As Boolean
Dim objShell As Object, objFolder As Object, AllFolders As Object, AllFiles As Object
Dim MySheet As Worksheet
On Error Resume Next
'************************
'Select folder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "", 0, 0)
If Not objFolder Is Nothing Then
MyPath = objFolder.self.Path & "\"
Else
Exit Sub
MyPath = "D:\Folder"
End If
Set objFolder = Nothing
Set objShell = Nothing
'************************
'List all folders
Set AllFolders = CreateObject("Scripting.Dictionary")
Set AllFiles = CreateObject("Scripting.Dictionary")
AllFolders.Add (MyPath), ""
i = 0
Do While i < AllFolders.Count
Key = AllFolders.keys
MyFolderName = Dir(Key(i), vbDirectory)
Do While MyFolderName <> ""
If MyFolderName <> "." And MyFolderName <> ".." Then
If (GetAttr(Key(i) & MyFolderName) And vbDirectory) = vbDirectory Then
AllFolders.Add (Key(i) & MyFolderName & "\"), ""
End If
End If
MyFolderName = Dir
Loop
i = i + 1
Loop
'List all files
For Each Key In AllFolders.keys
MyFileName = Dir(Key & "*.*")
'MyFileName = Dir(Key & "*.PDF") 'only PDF files
Do While MyFileName <> ""
AllFiles.Add (MyFileName), Key
MyFileName = Dir
Loop
Next
'************************
'List all files in Files sheet
For Each MySheet In ThisWorkbook.Worksheets
If MySheet.Name = "Files" Then
Sheets("Files").Cells.Delete
F = True
Exit For
Else
F = False
End If
Next
If Not F Then Sheets.Add.Name = "Files"
'Sheets("Files").[A1].Resize(AllFolders.Count, 1) = WorksheetFunction.Transpose(AllFolders.keys)
Sheets("Files").[A1].Resize(AllFiles.Count, 1) = WorksheetFunction.Transpose(AllFiles.Items)
Sheets("Files").[B1].Resize(AllFiles.Count, 1) = WorksheetFunction.Transpose(AllFiles.keys)
Set AllFolders = Nothing
Set AllFiles = Nothing
End Sub
I have tried:
Do While MyFileName <> ""
With MyFileName
If IsEmpty(.Range("a" & FirstDataRowInSourceFile)) Then
NumOfRecordsInSourceFile = 0
Else
NumOfRecordsInSourceFile = _
.Range(.Range("a" & FirstDataRowInSourceFile), .Range("a" &
FirstDataRowInSourceFile).End(xlDown)).Rows.Count
End If
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
On Error GoTo 0
'...
'...
Set AllFolders = CreateObject("Scripting.Dictionary")
Set AllFiles = CreateObject("Scripting.Dictionary")
AllFolders.Add (MyPath), ""
i = 0
Do While i < AllFolders.Count
'...
'...
Immediately after creating the dictionary the Count will be zero, so i < AllFolders.Count will be false and your loop never runs.
This should do it:
Sub ListAllFilesInAllFolders()
Dim i As Long, objFolder As Object, wsFiles As Worksheet
Dim colFiles As Collection, arrFiles, wb, MyPath As String
Set objFolder = CreateObject("Shell.Application").BrowseForFolder(0, "", 0, 0)
If Not objFolder Is Nothing Then
MyPath = objFolder.self.Path & "\"
Else
Exit Sub '????????
MyPath = "D:\Folder\"
End If
Set colFiles = GetMatchingFiles(MyPath, "*.csv")
Debug.Print "Found " & colFiles.Count & " matching files"
ReDim arrFiles(1 To colFiles.Count, 1 To 3) 'size output array
Application.ScreenUpdating = False
For i = 1 To colFiles.Count
Set wb = Workbooks.Open(colFiles(i), ReadOnly:=True)
arrFiles(i, 1) = wb.Path
arrFiles(i, 2) = wb.Name
arrFiles(i, 3) = wb.Sheets(1).UsedRange.Rows.Count
wb.Close False
Next i
Application.ScreenUpdating = True
On Error Resume Next 'ignore error if no match
Set wsFiles = ThisWorkbook.Sheets("Files")
On Error GoTo 0 'stop ignoring errors
If wsFiles Is Nothing Then
Set wsFiles = ThisWorkbook.Worksheets.Add()
wsFiles.Name = "Files"
End If
wsFiles.Cells.ClearContents
wsFiles.Range("a2").Resize(colFiles.Count, 3).Value = arrFiles
End Sub
'Search beginning at supplied folder root, including subfolders, for
' files matching the supplied pattern. Return all matches in a Collection
Function GetMatchingFiles(startPath As String, filePattern As String) As Collection 'of paths
Dim colFolders As New Collection, colFiles As New Collection
Dim fso As Object, fldr, subfldr, fl
Set fso = CreateObject("scripting.filesystemobject")
colFolders.Add startPath 'queue up root folder for processing
Do While colFolders.Count > 0 'loop until the queue is empty
fldr = colFolders(1) 'get next folder from queue
colFolders.Remove 1 'remove current folder from queue
With fso.getfolder(fldr)
For Each fl In .Files
If UCase(fl.Name) Like UCase(filePattern) Then 'check pattern
colFiles.Add fl.Path 'collect the full path
End If
Next fl
For Each subfldr In .subFolders
colFolders.Add subfldr.Path 'queue any subfolders
Next subfldr
End With
Loop
Set GetMatchingFiles = colFiles
End Function
I have code to list all files in chosen folder. Now it creates new sheet with name "Files". How to modify this code to let user input folder name every time he clicks the button? So basically scenario would look like this:
Click button
Choose folder to List files from
Type new Worksheet name where files will be listed
Code processed
Click button
Choose folder to List files from
Type new Worksheet name where files will be listed
Code processed
Same actions till the end of the world
I have tried this one but probably have mistakes inputting to my code:
Dim NewName As String
NewName = InputBox("What Do you Want to Name the Sheet1 ?")
Sheets("Sheet1").Name = NewName
I have tried to modify this with:
Sheets.Add.Name = NewName
Sheets(NewName).[A1].Resize(AllFiles.Count, 1) = WorksheetFunction.Transpose(AllFiles.keys)
My code for listing files and full path to each file:
Sub ListAllFilesInAllFolders()
Dim MyPath As String, MyFolderName As String, MyFileName As String
Dim i As Integer, F As Boolean
Dim objShell As Object, objFolder As Object, AllFolders As Object, AllFiles As Object
Dim MySheet As Worksheet
On Error Resume Next
'************************
'Select folder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "", 0, 0)
If Not objFolder Is Nothing Then
'MyPath =
MyPath = objFolder.self.Path & "\"
Else
Exit Sub
End If
Set objFolder = Nothing
Set objShell = Nothing
'************************
'List all folders
Set AllFolders = CreateObject("Scripting.Dictionary")
Set AllFiles = CreateObject("Scripting.Dictionary")
AllFolders.Add (MyPath), ""
i = 0
Do While i < AllFolders.Count
Key = AllFolders.keys
MyFolderName = Dir(Key(i), vbDirectory)
Do While MyFolderName <> ""
If MyFolderName <> "." And MyFolderName <> ".." Then
If (GetAttr(Key(i) & MyFolderName) And vbDirectory) = vbDirectory Then
AllFolders.Add (Key(i) & MyFolderName & "\"), ""
End If
End If
MyFolderName = Dir
Loop
i = i + 1
Loop
'List all files
For Each Key In AllFolders.keys
MyFileName = Dir(Key & "*.*")
'MyFileName = Dir(Key & "*.PDF") 'only PDF files
Do While MyFileName <> ""
AllFiles.Add (Key & MyFileName), ""
MyFileName = Dir
Loop
Next
'************************
'List all files in Files sheet
For Each MySheet In ThisWorkbook.Worksheets
If MySheet.Name = "Files" Then
Sheets("Files").Cells.Delete
F = True
Exit For
Else
F = False
End If
Next
If Not F Then Sheets.Add.Name = "Files"
'Sheets("Files").[A1].Resize(AllFolders.Count, 1) = WorksheetFunction.Transpose(AllFolders.keys)
Sheets("Files").[A1].Resize(AllFiles.Count, 1) = WorksheetFunction.Transpose(AllFiles.keys)
Set AllFolders = Nothing
Set AllFiles = Nothing
End Sub
Try using
With Sheets.Add
.Name = NewName
.Range("A1").Resize(AllFiles.Count, 1) = WorksheetFunction.Transpose(AllFiles.keys)
End With
Also, no need to to loop to test if the sheet exists. Use Error Handling instead
Dim FilesSheet as Worksheet
On Error Resume Next
Set FilesSheet = Thisworkbook.Sheets("Files")
On Error GoTo 0
If Not FilesSheet is Nothing then
F = True
Set FilesSheet = ThisWorkbook.Sheets.Add
FilesSheet.Name = NewName
Else
F = False
FilesSheet.Cells.Delete
End If
FilesSheet.Range("A1").Resize(AllFiles.Count, 1) = WorksheetFunction.Transpose(AllFiles.keys)
If you are creating this for End Users you may also want to build in functionality to check that the NewName they enter isn't too long (>31 Characters) for an Excel Sheet Name and doesn't contain any illegal characters (\ / * [ ] : ?)
I have created a code to give me path and there names for all the files in a folder to excel.
But my problem is its giving me file names of all the files in that folder. I just want to search and retrieve names of only pdf files to excel.
Here is what I have:
Sub Example1()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(Range("H1").Value)
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file path
Cells(i + 3, 2) = objFile.Path
i = i + 1
Next objFile
End Sub
As per the comments. You need to test if the last three characters are 'pdf'
So in your for loop add the if statement
For Each objFile In objFolder.Files
if right(objFile.Path,3) = "pdf" then
'print file path
Cells(i + 3, 2) = objFile.Path
i = i + 1
end if
Next objFile
This should work:
Sub Find_PDF()
Dim FileToCheck As String, FilePath As String, FileWildCard As String
FilePath = "c:\YOUR FILE PATH\"
FileWildCard = "*.pdf"
FileToCheck = Dir(FilePath & FileWildCard)
Do While FileToCheck <> ""
i = i + 1
Sheets("Sheet1").Range("A" & i).Value = FileToCheck
FileToCheck = Dir()
Loop
End Sub
This is not a free coding service but i would answer this anyway:
For Each objFile In objFolder.Files
if right(objFile.Path,3) = "pdf" then
'print file path
Cells(i + 3, 2) = objFile.Path
i = i + 1
end if
msgbox ("Answer are here dont troll on someone")
Next objFile
I have made a script that allows the user to open a file using the shell browser and once selected they are prompted to enter the interval in which they want to split the .CSV file down into smaller files.
The problem that arises is that once I select the file using the browser I get an unspecified error with the code 80004005 it appears on line 15 character 1 and I have no idea how to solve this.
Any help would be much appreciated!
Option Explicit
Const ForReading = 1
Const ForWriting = 2
Dim objFSO, objInputFile, objOutputFile
Dim intLine, intFile
Dim strHeaders
Dim strInputFile, strOutputPrefix, strLine
Dim MyDate
Dim shell
Dim file
Set shell = CreateObject("Shell.Application")
Set file = shell.BrowseForFolder(0, "Choose a file:", &H4000)
BrowseForFile = file.self.Path
strInputFile = BrowseForFile
strOutputPrefix = objFSO.GetBaseName(strInputFile) & DatePart("yyyy", Now) & "-" & DatePart("m", Now) & "-" & DatePart("d", Now)
userSplit = InputBox("Enter when you want to split")
intFile = 1
intLine = 0
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objInputFile = objFSO.OpenTextFile(strInputFile, ForReading)
If (objInputFile.AtEndOfStream = True) Then
' The file is empty
WScript.Quit 1
End If
strHeaders = objInputFile.ReadLine
Do While (objInputFile.AtEndOfStream = False)
strLine = objInputFile.ReadLine
If (intLine <= 0) Then
Set objOutputFile = objFSO.CreateTextFile(strOutputPrefix & "_" & intFile & ".csv", True)
objOutputFile.WriteLine strHeaders
intLine = 1
End If
objOutputFile.WriteLine strLine
If (intLine >= userSplit) Then
objOutputFile.Close
Set objOutputFile = Nothing
intFile = intFile + 1
intLine = 0
Else
intLine = intLine + 1
End If
Loop
Your BrowseForFolder call misses the third/option parameter; so change
Set file = shell.BrowseForFolder(0, "Choose a file:", &H4000)
to
Set file = shell.BrowseForFolder(0, "Choose a file:", 0, &H4000)
The above (kept for context for comments) is all wrong
The docs state clearly:
Creates a dialog box that enables the user to select a folder and then
returns the selected folder's Folder object.
so you can display the files, but not pick/return them.
i want to convert excel files into tab limited txt files(without carriage returns). Currently i'm using the script(found in this forum) which converts mass excel files into .txt files.
the script is
' #file: xl2tab.vbs
' #author: stephen brown - sb09d#fsu.edu
' #date: 2009-Dec-10
'
' #description: mass convert excel files to tab-delimited files
'
' #usage: place in top-level directory where excel files are contained and double-click.
' script will recursively access all subdirectories and convert each excel file to
' tab delimited file. All output will be in "output" folder, which retains structure
' of original directories
Dim saveDirBase
set fso = CreateObject("Scripting.FileSystemObject")
set shell = CreateObject("WScript.Shell")
set objExcel = CreateObject("Excel.Application")
set top = fso.GetFolder(shell.CurrentDirectory)
saveDirBase = top & "\" & "output"
Sub TraverseFolders(path)
set folder = fso.GetFolder(path)
XL2Tab(folder)
For each item in folder.SubFolders
If item.Path <> saveDirBase Then
Call TraverseFolders(item.Path)
End If
Next
set folder = Nothing
End Sub
Sub XL2Tab(folder)
Dim saveDir
set files = folder.Files
If folder.Name <> top.Name Then
saveDir = saveDirBase & "\" & folder.Name
Else
saveDir = saveDirBase
End If
If fso.FolderExists(saveDir) = False Then
fso.CreateFolder(saveDir)
End If
For each file In files
If file.Name <> Wscript.ScriptName Then
objExcel.Application.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.open(folder.Path & "\" & file.Name)
objWorkbook.SaveAs saveDir & "\" & file.Name & ".txt", -4158
objWorkbook.close
objExcel.Application.DisplayAlerts = True
End If
Next
End Sub
If fso.FolderExists(saveDirBase) = False Then
fso.CreateFolder(saveDirBase)
End If
Call TraverseFolders(top)
Before converting i want to remove carriage return in every excel file.
Please guide me anyone...!
Hi If you are trying to remove carriage returns after converting the file add the below procedure to code
sub RemoveCarriage(FileN)
Const ForReading = 1
Const ForWriting = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(FileN, ForReading)
strText = objFile.ReadAll
objFile.Close
strNewText = Replace(strText, chr(013) & chr(010), "")
' chr(010) = line feed chr(013) = carriage return
Set objFile = objFSO.OpenTextFile(FileN, ForWriting)
objFile.WriteLine strNewText
objFile.Close
End sub
Call the module inside forloop of your procedure just after closing the workbook
objWorkbook.close
RemoveCarriage(file.Name & ".txt")