I make a code then ask the user where he wants to put a text file created from an excel sheet.
if the selected folder is named formatted file, then a file should create. if the folder formatted file doesn't exist, the code should create a file named formatted Files and then create the text file in it.
the text file contains 4 columns of data from excel.
For now, the folder is created in the right place. the code is update with the correct solution.
if there's a way to simplify my code let me know!!
Here's my actual code:
Sub register_formated_data()
'
' register_formated_data Macro
'
Dim order As Object
Dim Folder As Object
Dim Folder_path As String
Dim lastrow As Long
Dim fSo As Object
Dim myFile As Object
FolderName = "Formated Files"
Filename = "formated" & Right(Sheets(8).Cells(12, 6).Value, InStr(File_path, "\"))
Dim FL As String ' FL is for file location
Sheets(8).Cells(12, 12).Value = ""
With Application.FileDialog(msoFileDialogFolderPicker) '
.Title = "Select where you want the folder to be" 'Open the file explorer
.InitialFileName = ThisWorkbook.path & "\" 'for you to select
.InitialView = msoFileDialogViewDetails 'the file you want
.AllowMultiSelect = True 'to add the txt file
.Show '
On Error GoTo PROC_EXIT
If Not .SelectedItems(1) = vbNullString Then FL = .SelectedItems(1)
End With
Sheets(8).Cells(12, 12).Value = FL
Folder_path = FL + "\" + FolderName
Set fSo = CreateObject("Scripting.FileSystemObject")
If Not fSo.FolderExists(Folder_path) Then
fSo.CreateFolder (Folder_path)
If fSo.FolderExists(Folder_path) Then
Set fSo = CreateObject("Scripting.FileSystemObject")
Set myFile = fSo.CreateTextFile(Folder_path + "\" + Filename, True)
myFile.WriteLine "Error"
myFile.Close
Set fSo = Nothing
End If
Else
If fSo.FolderExists(Folder_path) Then
Set fSo = CreateObject("Scripting.FileSystemObject")
Set myFile = fSo.CreateTextFile(Folder_path + "\" + Filename, True)
myFile.WriteLine "Error"
myFile.Close
Set fSo = Nothing
End If
End If
PROC_EXIT:
End Sub
As FL is picked using a FileDialog, it seems you are trying to create folder FL when it already exists.
Using
fSo.CreateFolder(FL).Name = FolderName
is equivalent to
folder = fSo.CreateFolder(FL)
folder.Name = FolderName
So you need to substitute it by fSo.CreateFolder(FolderName).
The corrected code block is then:
Set fSo = CreateObject("Scripting.FileSystemObject")
If Not fSo.FolderExists(Folder_path) Then
fSo.CreateFolder(Folder_path)
If fSo.FolderExists(Folder_path) Then
Set fSo = CreateObject("Scripting.FileSystemObject")
Set myFile = fSo.CreateTextFile(Folder_path + "\" + Filename, True)
myFile.WriteLine "Error"
myFile.Close
Set fSo = Nothing
End If
End If
Related
I have created an excel macro, which loops through the different subfolders of a fixed parent folder. The parent folder directory does not change. I have found a code on the net, which first lets me choose the folder to scan, which is nice, but is awkward for my purpose, since I run the code several times and each time I have to choose the folder again.
Instead I would like to give the macro the fixed full path and do without the prompt to choose the folder. I have written the following code, but do not know how to adjust it to make it work the way I described. Could you give me some advise?
This is the code:
Dim MyPath As String, MyFolderName As String, MyFileName As String, strStartCell2 As String, strFolderToScan As String
Dim i As Integer
Dim F As Boolean
Dim objShell As Object, objFolder As Object, AllFolders As Object, AllFiles As Object, strFileFormat As Object, fso As Object
Dim MySheet As Worksheet
'Define variables and constants
Set strFileFormat = ThisWorkbook.Worksheets("Makro").Range("A6")
strStartCell2 = strStartCell
strFolderToScan = ThisWorkbook.Worksheets("Makro").Range("C4").Value & "\"
'Select folder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please select the folder you would like to scan", 0, 0)
If Not objFolder Is Nothing Then
MyPath = objFolder.self.Path & "\"
ThisWorkbook.Worksheets("Sheet1").Range("B3").Value = MyPath
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 & "*." & strFileFormat)
Do While MyFileName <> ""
AllFiles.Add (Key & MyFileName), ""
MyFileName = Dir
Loop
Next
'List all files in Files sheet
Sheets("Makro").Range(strStartCell2).Resize(AllFiles.Count, 1) = WorksheetFunction.Transpose(AllFiles.keys)
Set AllFolders = Nothing
Set AllFiles = Nothing
Probably this is simple, but i just can't figure out how to do it.
Thanks a lot in advance!
Oliver
This is the relevant part for selecting the folder
'Select folder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please select the folder you would like to scan", 0, 0)
If Not objFolder Is Nothing Then
MyPath = objFolder.self.Path & "\"
ThisWorkbook.Worksheets("Sheet1").Range("B3").Value = MyPath
Else
Exit Sub
End If
Set objFolder = Nothing
Set objShell = Nothing
Especially the objShell.BrowseForFolder is the part that asks you to browse for the folder. So you need to replace that to use strFolderToScan directly. We do that by using objShell.GetFolder(strFolderToScan) to get the folder from your path strFolderToScan.
But I recommend to check if the folder actually exists, so you do not run into errors:
'Select folder
Set objShell = CreateObject("Shell.Application")
If objShell.FolderExists(strFolderToScan) Then
MyPath = strFolderToScan
ThisWorkbook.Worksheets("Sheet1").Range("B3").Value = MyPath
Else
MsgBox "The folder '" & strFolderToScan & "' does not exist."
Exit Sub
End If
Set objShell = Nothing
I need to do the following:
Allow the user to select any number of files, in any format, and copy them to a new folder.
Create the destination folder if it doesn't exist. In this case, the folder name should be given by the content of the C2 & C3 cells (Range("C2").Value & Range("C3").Text & "\").
Private Sub CommandButton4_Click()
Dim strDirname As String
Dim strDefpath As String
Dim strPathname As String
Dim strFilename As String
Dim FSO
Dim sFile As FileDialog
Dim sSFolder As String
Dim sDFolder As String
strDirname = Range("C2").Value & Range("C3").Text
MkDir strDefpath & "\" & strDirname
strPathname = strDefpath & "\" & strDirname & "\" & strFilename
Set sFile = Application.FileDialog(msoFileDialogOpen)
sDFolder = strDirname & "\"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FSO = New FileSystemObject
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
If Not .Show Then Exit Sub
Set xFolder = FSO.GetFolder(.SelectedItems(1))
For Each xFile In xFolder.Files
On Error Resume Next
xRow = Application.Match(xFile.Name, Range("A:A"), 0)
On Error GoTo 0
Next
End With
End Sub
I know the error is here...
Set xFolder = FSO.GetFolder(.SelectedItems(1))
...because I'm asking it to get a file, not a folder.
It is not very clear to me what you are trying to do but, if you intend to select a folder, you have to use it
Application.FileDialog (msoFileDialogFolderPicker)
instead of
Application.FileDialog (msoFileDialogFilePicker)
Your posted code shows so little resemblance to what you Q asks for, I've disregarded it.
This code follows the description. You may need to alter certain details to fully match your needs
Sub Demo()
Dim FilePicker As FileDialog
Dim DefaultPath As String
Dim DestinationFolderName As String
Dim SelectedFile As Variant
Dim DestinationFolder As Folder
Dim FSO As FileSystemObject
DefaultPath = "C:\Data" ' <~~ update to suit, or get it from somewhere else
' Validate Default Path
If Right$(DefaultPath, 1) <> Application.PathSeparator Then
DefaultPath = DefaultPath & Application.PathSeparator
End If
If Not FSO.FolderExists(DefaultPath) Then Exit Sub
' Get Destination Folder, add trailing \ if required
DestinationFolderName = Range("C2").Value & Range("C3").Value
If Right$(DestinationFolderName, 1) <> Application.PathSeparator Then
DestinationFolderName = DestinationFolderName & Application.PathSeparator
End If
Set FSO = New FileSystemObject
' Get reference to Destination folder, create it if required
If FSO.FolderExists(DefaultPath & DestinationFolderName) Then
Set DestinationFolder = FSO.GetFolder(DefaultPath & DestinationFolderName)
Else
Set DestinationFolder = FSO.CreateFolder(DefaultPath & DestinationFolderName)
End If
' File Selection Dialog
Set FilePicker = Application.FileDialog(msoFileDialogFilePicker)
With FilePicker
.AllowMultiSelect = True ' allow user to select multiple files
.InitialFileName = DefaultPath ' set initial folder for dialog
If .Show = False Then Exit Sub ' check if user cancels
For Each SelectedFile In .SelectedItems ' loop over selected files
If SelectedFile Like DefaultPath & "*" Then 'Optional: disallow browsing higher than default folder
FSO.CopyFile SelectedFile, DefaultPath & DestinationFolderName, True ' Copy file, overwrite is it exists
End If
Next
End With
End Sub
I'm preparing a code which would every month help users rename specific string in multiple files.
Example: from "Jan" to "Feb", from "Bank" to "Cash", from "Test" to "Sharp" etc. (Bank Statement Jan.xls -> JPM Statement Jan.xls, Form test.xls -> Form sharp.xls, etc.)
I use a function to populate files from all folders and also subfolder picked up a FileDialog, then I prompt the user to InputBox string to be found and string to be replaced in the file name.
Sub testrenametest()
Dim filedlg As FileDialog
Dim xPath As String
Dim fileList As Object
Dim vFile As Variant
Dim FindTerm As String, ReplaceTerm As String, NewFileName As String
Set filedlg = Application.FileDialog(msoFileDialogFolderPicker)
With filedlg
.Title = "Please select folder"
.InitialFileName = ThisWorkbook.Path
If .Show <> -1 Then End
xPath = .SelectedItems(1) & "\"
End With
FindTerm = InputBox("Find string:") ReplaceTerm = InputBox("Replace with:")
Set fileList = getFileList(xPath)
For Each vFile In fileList
If vFile Like "*" & FindTerm & "*" Then
NewFileName = Replace(vFile, FindTerm, ReplaceTerm)
Name vFile As NewFileName
End If
Next vFile
End Sub
Function getFileList(Path As String, Optional FileFilter As String = "*.*", Optional fso As Object, Optional list As Object) As Object
Dim BaseFolder As Object, oFile As Object
If fso Is Nothing Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set list = CreateObject("System.Collections.ArrayList")
End If
If Not Right(Path, 1) = "\" Then Path = Path & "\"
If Len(Dir(Path, vbDirectory)) = 0 Then
MsgBox "You need to browse folder first!"
End
End If
Set BaseFolder = fso.GetFolder(Path)
For Each oFile In BaseFolder.SubFolders
getFileList oFile.Path, FileFilter, fso, list
Next
For Each oFile In BaseFolder.Files
If oFile.Path Like FileFilter Then list.Add oFile.Path
Next
Set getFileList = list
End Function
It works for some strings like month names but for instance for "test" or "bank" doesn't. It says Run-time error 53 File not found on line Name vFile As NewFileName, but the file exists. Sorry for inputting the whole code, but I am unable to pinpoint where might be a problem.
Your problem probably lies in the fact that it is attempting to rename a file inside the loop that no longer exists with that name. Condition the rename by first double-checking to make sure the file still exists.
For Each vFile In fileList
If vFile Like "*" & FindTerm & "*" Then
NewFileName = Replace(vFile, FindTerm, ReplaceTerm)
If Dir$(vFile) <> "" Then
Name vFile As NewFileName
End If
End If
Next vFile
Edit: after additional feedback was provided that the problem is that the replaced string was also found in the path, I suggest the following fix:
For Each vFileSpec In fileList
vPath = Left(vFile, InstrRev(vFileSpec, "\") - 1)
vFile = Mid(vFileSpec, Len(vPath) + 1)
If vFile Like "*" & FindTerm & "*" Then
NewFileName = Replace(vFile, FindTerm, ReplaceTerm)
Name vFileSpec As vPath + "\" + NewFileName
End If
Next vFile
Trying to use fso technique to copy from source folder C:\ ( V) to target folder C:(All) but running code give message runtime error 53. file not found
What I am trying to achieve is to copy all xlsx file from source folder C:\ V which contains also other file extension pdf, csv, txt, word..
All xlsx will be copied to folder C:\ALL,
Getting runtime error on this line below
****FSO.CopyFile Source:=sourcePath & fileExtn, Destination:=destinationPath****
Sub copy_specific_files_in_folder()
Dim FSO As Object
Dim sourcePath As String
Dim destinationPath As String
Dim fileExtn As String
sourcePath = "c:\V"
destinationPath = "c:\all\"
fileExtn = " * .xlsx"
If Right(sourcePath, 1) <> "\" Then
sourcePath = sourcePath & "\"
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(sourcePath) = False Then
MsgBox sourcePath & " does not exit"
Exit Sub
End If
If FSO.FolderExists(destinationPath) = False Then
MsgBox destinationPath & " does not exit"
Exit Sub
End If
FSO.CopyFile Source:=sourcePath & fileExtn, Destination:=destinationPath
copy_files_from_subfolders
MsgBox "your files have been copied from subfolders of " & sourcePath & "to" & destinationPath
End Sub
Sub copy_files_from_subfolders()
Dim FSO As Object, fld As Object
Dim fsoFile As Object
Dim fsoFol As Object
sourcePath = "c:\V"
targetpath = "c:\all\"
If Right(sourcePath, 1) <> “ \ ” Then sourcePath = sourcePath & “ \ ”
Set FSO = CreateObject(“scripting.filesystemobject”)
Set fld = FSO.GetFolder(sourcePath)
If FSO.FolderExists(fld) Then
For Each fsoFol In FSO.GetFolder(sourcePath).SubFolders
For Each fsoFile In fsoFol.Files
If Right(fsoFile, 4) = “xlsx” Then
fsoFile.Copy targetpath
End If
Next
Next
End If
End Sub
Hi change fileExtn = " * .xlsx" to fileExtn = "*.xlsx" and that should fix your issue.
EDIT
The code below should fix your other sub procedure.
Sub copy_files_from_subfolders()
Dim FSO As Object, fld As Object
Dim fsoFile As Object
Dim fsoFol As Object
sourcePath = "c:\V"
targetpath = "c:\all\"
If Right(sourcePath, 1) <> "\" Then sourcePath = sourcePath & "\"
Set FSO = CreateObject("scripting.filesystemobject")
Set fld = FSO.GetFolder(sourcePath)
If FSO.FolderExists(fld) Then
For Each fsoFol In FSO.GetFolder(sourcePath).SubFolders
For Each fsoFile In fsoFol.Files
If Right(fsoFile, 4) = “xlsx” Then
fsoFile.Copy targetpath
End If
Next
Next
End If
End Sub
I have checked "Sub copy_specific_files_in_foldera()" works, it copies all files in main directory from c:\v to c:\all but in applying your edit . I get compile error message variable not defined sourcePath . the "Sub copy_files_from_subfolders()" in yellow.
Sub copy_specific_files_in_foldera()
Dim FSO As Object
Dim sourcePath As String
Dim destinationPath As String
Dim fileExtn As String
sourcePath = "c:\V"
destinationPath = "c:\all\"
fileExtn = "*.xlsx"
If Right(sourcePath, 1) <> "\" Then
sourcePath = sourcePath & "\"
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(sourcePath) = False Then
MsgBox sourcePath & " does not exit"
Exit Sub
End If
If FSO.FolderExists(destinationPath) = False Then
MsgBox destinationPath & " does not exit"
Exit Sub
End If
FSO.CopyFile Source:=sourcePath & fileExtn, Destination:=destinationPath
'copy_files_from_subfolders 'suspend'
MsgBox "your files have been copied from subfolders of " & sourcePath & "to" & destinationPath
End Sub
Generally too much hard-coding in the functions/subs.
Keep the variables as inputs:
I have added a Reference to Microsoft.Scripting.Runtime
Sub CopyFiles(extension As String, sourceFolder As String, targetFolder As String, recursive As Boolean)
Dim fso As New FileSystemObject
Dim src As folder, dest As folder
Set src = fso.GetFolder(sourceFolder)
Set dest = fso.GetFolder(targetFolder)
Dim srcFile As File
For Each srcFile In src.Files
Dim srcFilepath As String
srcFilepath = srcFile.Path
If Right(srcFilepath, Len(srcFilepath) - InStrRev(srcFilepath, ".") + 1) = extension Then 'extension includes the "."
srcFile.Copy targetFolder, True 'I set Overwrite to True
End If
Next srcFile
If recursive Then 'If recursive is True then will go through all subfolders recursively
Dim subDir As folder
For Each subDir In src.SubFolders
CopyFiles extension, subDir.Path, targetFolder, True
Next subDir
End If
End Sub
Sub testCopy()
CopyFiles ".xlsm", "C:\Source", "C:\Destination\", True
End Sub
Can anyone please review code below and tell me where am I going wrong?
Basically what I am trying to achieve, user inputs name in the Column A, then will click upload button (same row, column F), excel would create a folder using name from Column A, via filedialog window user will select multiple files which should be copied to newly created folder, finally excel would also additionally create path to the folder (saved in column D) and stamp the date (column E).
Current problems:
Fails to copy multiple files, currently I can only copy one file
File is copied to parent folder of newly created folders, basically
fails to copy to newly created folder itself.
My code:
Sub Button1_Click()
Dim objFSO As Object
Dim objFile As Object
Dim openDialog As FileDialog
Dim Foldername As String
Dim Path As String
Dim Newpath As String
Dim i As Integer
Dim myfile As String
Dim myfilePath As String
Foldername = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -5).Value
Path = "C:\Test\"
Set openDialog = Application.FileDialog(msoFileDialogFilePicker)
openDialog.AllowMultiSelect = True
Set objFSO = CreateObject("Scripting.FileSystemObject")
For i = 1 To openDialog.SelectedItems.Count
myfile = openDialog.SelectedItems.Item(i)
Next
If openDialog.Show = -1 Then
If Dir(Path & Foldername, vbDirectory) = "" Then
MkDir Path & Foldername
End If
objFSO.CopyFile myfile, Path
ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -2).Hyperlinks.Add ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -2), Address:=Path & Foldername, TextToDisplay:="Open Folder"
ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -1).Value = Format(Now, "MM/dd/yyyy")
MsgBox "Files were successfully copied"
End If
End Sub
Your For loop was in the wrong place. This is why you were not able to loop through every file and copy it.
You have this problem, because you used objFSO.CopyFile myfile, Path instead of the newly created folder name. I changed that part with this: objFSO.CopyFile myfile, Path & Foldername & "\" . Note that Path & Foldername is not enough, as you need to have \ at the end.
The working code:
Sub Button1_Click()
Dim objFSO As Object
Dim objFile As Object
Dim openDialog As FileDialog
Dim Foldername As String
Dim Path As String
Dim Newpath As String
Dim i As Integer
Dim myfile As String
Dim myfilePath As String
Foldername = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -5).Value
Path = "C:\Test\"
Set openDialog = Application.FileDialog(msoFileDialogFilePicker)
openDialog.AllowMultiSelect = True
Set objFSO = CreateObject("Scripting.FileSystemObject")
If openDialog.Show = -1 Then
If Dir(Path & Foldername, vbDirectory) = "" Then
MkDir Path & Foldername
End If
For i = 1 To openDialog.SelectedItems.Count
myfile = openDialog.SelectedItems.Item(i)
objFSO.CopyFile myfile, Path & Foldername & "\"
Next
ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -2).Hyperlinks.Add ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -2), Address:=Path & Foldername, TextToDisplay:="Open Folder"
ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -1).Value = Format(Now, "MM/dd/yyyy")
MsgBox "Files were successfully copied"
End If
Set objFSO = Nothing
Set openDialog = Nothing
End Sub