I'm trying to create folders in a test folder through vba, but it doesn't work. I can't figure out why - the commands seem legal.
Option Explicit
Sub createFolders()
Dim homePath As String
Dim folderName As String
Dim foldersNumber As Long
homePath = ThisWorkbook.Worksheets("setup").Cells(1, 2).Value & "\"
folderName = ThisWorkbook.Worksheets("setup").Cells(2, 2).Value
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim i As Long
For i = 1 To foldersNumber
If Not fso.FolderExists(homePath & folderName & i) Then
fso.CreateFolder (homePath & folderName & i)
Else
MsgBox ("Folder exits")
End If
Next
MsgBox ("DONE")
End Sub
Related
I have a directory that has 1000's of files. The filename string goes like: ManagerName_EmployeeName_First Assessment.xlsx
but I have a specific type of grouping I need to execute so that I have folders go by ManagerName > Employee Name and then the 5 types of Assessments in the employees folder.
How would I edit this to identify the first _ in the filename (ManagerName) and then make a folder by that ManagerName and then make a subfolder by EmployeeName and then house all five files under that employee in the employee subfolder?
I know you'd need to use a Left(fileName, InStrRev(fileName, "_") > 1) type function to identify the first text string to the left of the first _ but how would I go and create a second subfolder based on the employee under that manager?
Here's a shell of the code I was thinking:
Option Explicit
Sub MoveFiles()
Dim objFSO As Object
Dim objMyFolder As Object
Dim objMyFile As Object
Dim strSourceFolder As String
Dim strDestFolder As String
Application.ScreenUpdating = False
strSourceFolder = "C:\Users\CIB\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objMyFolder = objFSO.GetFolder(strSourceFolder)
For Each objMyFile In objMyFolder.Files
Do While objMyFile <> ""
strDestFolder = Left(objMyFile.Name, InStrRev(objMyFile, "_") - 1)
If Len(Dir(strDestFolder, vbDirectory)) = 0 Then
MkDir strDestFolder
End If
FileCopy strSourceFolder & "\" & objMyFile.Name, strDestFolder & "\" & objMyFile.Name
Kill strSourceFolder & "\" & objMyFile.Name
Loop
Next objMyFile
Set objFSO = Nothing
Set objMyFolder = Nothing
Application.ScreenUpdating = True
End Sub
I've changed your code accordingly to TimWiliams suggestions:
Option Explicit
Sub MoveFiles()
Dim objFSO As Object
Dim objMyFolder As Object
Dim objMyFile As Object
Dim strSourceFolder As String
Dim strDestFolder As String
Dim parts() As String
Dim i As Integer
Application.ScreenUpdating = False
strSourceFolder = "C:\Users\CIB\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objMyFolder = objFSO.GetFolder(strSourceFolder)
For Each objMyFile In objMyFolder.Files
If objMyFile Is Nothing Then GoTo SkipNext
parts = Split(objMyFile.Name, "_")
strDestFolder = strSourceFolder
For i = LBound(parts) To UBound(parts) - 1
strDestFolder = strDestFolder & parts(i) & "\"
'if path does not exists, create it
If Not objFSO.FolderExists(strDestFolder) Then objFSO.CreateFolder strDestFolder
FileCopy strSourceFolder & "\" & objMyFile.Name, strDestFolder & "\" & objMyFile.Name
Kill strSourceFolder & "\" & objMyFile.Name
strDestFolder = ""
SkipNext:
Next objMyFile
Set objFSO = Nothing
Set objMyFolder = Nothing
Application.ScreenUpdating = True
End Sub
I am a google search coder on VBA.
I have a local folder in my PC with around 5000+ pdfs.
I decided to sort pdf into folder which has the same names. the execution of the code is extremely lengthy as the code has to loop through 5000+ so that the sort happens accordingly. The below code works fine. I can live with it too.
Just out of curiosity I am posting this question, if there is a method to do this task at a faster rate.
Sub Create_FoldersAndExtractFiles()
Dim sh1 As Object
'for going through the files Dim FSO As Scripting.fileSystemObject Dim
SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
fname As String
Set fso = New Scripting.FileSystemObject
'http://excelspreadsheetshelp.blogspot.com penAt = "My computer:\"
Set sh1 = ThisWorkbook.Sheets("Sheet1")
Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, "Please Choose The Folder For This Project", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
scr_Folder = ShellApp.self.Path
'create the folders where-ever the workbook is saved
lrow = sh1.Range("a" & Rows.Count).End(xlUp).Row
If lrow = 1 Then
MsgBox "No data to create the folder"
Else
For i = 2 To lrow
fname = sh1.Range("a" & i)
'to create a new folder
If Len(Dir(ActiveWorkbook.Path & "\" & fname, vbDirectory)) = 0 Then
MkDir (scr_Folder & "\" & fname)
End If
'to move the file into a folder
dst_folder = scr_Folder & "\" & fname
Set SourceFolder = fso.GetFolder(scr_Folder)
For Each FileItem In SourceFolder.Files
mname = Left(FileItem.NAME, InStr(1, FileItem.NAME, ".") - 1)
If InStr(LCase(mname), LCase(fname)) Then
fso.MoveFile Source:=scr_Folder & "\" & mname & "*.*", Destination:=dst_folder
End If
Next
Next
Set FileItem = Nothing
Set SourceFolder = Nothing
Set fso = Nothing
End If
MsgBox "Done"
End Sub
How about replacing the section (the loop)
For Each FileItem In SourceFolder.Files
mname = Left(FileItem.NAME, InStr(1, FileItem.NAME, ".") - 1)
If InStr(LCase(mname), LCase(fname)) Then
fso.MoveFile Source:=scr_Folder & "\" & mname & "*.*", Destination:=dst_folder
End If
Next
with just this line:
fso.MoveFile Source:=scr_Folder & "\*" & fname & "*.*", Destination:=dst_folder
As in the Question: the task is to extract all files names from a folder, but the folder path needs to be hard coded into the macro, to prevent these dialog boxes asking me things and wasting my time.
I will not change this folder. It will be the same one until the end of time, and I want to extract the files names into the Excel column, starting from second row.
this is the folder I want to extract ALL files names from.
"C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\"
this is my portion of code:
Option Explicit
Sub GetFileNames()
Dim axRow As Long ' inside the Sheet("Lista") row#
Dim xDirectory As String
Dim xFname As String ' name of the file
Dim InitialFoldr$
Dim start As Double
Dim finish As Double
Dim total_time As Double
start = Timer
ThisWorkbook.Sheets("Lista").Range("D2").Activate
InitialFolder = "C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst"
If Right(InitialFolder, 1) <> "\" Then
InitialFolder = InitialFolder & "\"
End If
Application.InitialFolder.Show
If InitialFolder.SelectedItems.Count <> 0 Then
xDirectory = .SelectedItems(1) & "\"
xFname = Dir(xDirectory, vbArchive)
' Dir's job is to return a string representing
' the name of a file, directory, or an archive that matches a specified pattern.
Do While xFname <> "" ' there is already xFname value (1st file name) assigned.
ActiveCell.Offset(xRow) = xFname
xRow = xRow + 1 ' następny xRow
xFname = Dir()
Loop
End If
End With
finish = Timer ' Set end time.
total_time = Round(finish - start, 3) ' Calculate total time.
MsgBox "This code ran successfully in " & total_time & " seconds", vbInformation
End Sub
this is the line that crushes:
If InitialFolder.SelectedItems.Count <> 0 Then
xDirectory = .SelectedItems(1) & "\"
And two more important questions in the .png file.
Please, respond to them as well - it's very important 4 me.
Or if U guys know any other method to do this faster just don't hesitate and share Your Code with me - I'll be very grateful.
Sub Files()
Dim sht As Worksheet
Dim strDirectory As String, strFile As String
Dim i As Integer: i = 1
Set sht = Worksheets("Sheet1")
strDirectory = "C:\Users\User\Desktop\"
strFile = Dir(strDirectory, vbNormal)
Do While strFile <> ""
With sht
.Cells(i, 1) = strFile
.Cells(i, 2) = strDirectory + strFile
End With
'returns the next file or directory in the path
strFile = Dir()
i = i + 1
Loop
End Sub
See example below
Public Sub Listpng()
Const strFolder As String = "C:\SomeFolder\"
Const strPattern As String = "*.png"
Dim strFile As String
strFile = Dir(strFolder & strPattern, vbNormal)
Do While Len(strFile) > 0
Debug.Print strFile '<- view this in Immediate window; Ctrl+g will take you there
strFile = Dir
Loop
End Sub
There's a couple of procedures I use depending on whether I want subfolders as well.
This loops through the folder and adds path & name to a collection:
Sub Test1()
Dim colFiles As Collection
Dim itm As Variant
Set colFiles = New Collection
EnumerateFiles "C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\", "*.xls*", colFiles
For Each itm In colFiles
Debug.Print itm
Next itm
End Sub
Sub EnumerateFiles(ByVal sDirectory As String, _
ByVal sFileSpec As String, _
ByRef cCollection As Collection)
Dim sTemp As String
sTemp = Dir$(sDirectory & sFileSpec)
Do While Len(sTemp) > 0
cCollection.Add sDirectory & sTemp
sTemp = Dir$
Loop
End Sub
This second way goes through the subfolders as well returning path & name. For some reason if you change InclSubFolders to False it only returns the name - got to sort that bit out.
Sub Test2()
Dim vFiles As Variant
Dim itm As Variant
vFiles = EnumerateFiles_2("C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\", "xls*")
For Each itm In vFiles
Debug.Print itm
Next itm
End Sub
Public Function EnumerateFiles_2(sDirectory As String, _
Optional sFileSpec As String = "*", _
Optional InclSubFolders As Boolean = True) As Variant
EnumerateFiles_2 = Filter(Split(CreateObject("WScript.Shell").Exec _
("CMD /C DIR """ & sDirectory & "*." & sFileSpec & """ " & _
IIf(InclSubFolders, "/S ", "") & "/B /A:-D").StdOut.ReadAll, vbCrLf), ".")
End Function
I have written the below script which creates a folder in a given location if it doesn't exist which is named after a cell in the workbook.
Dim fso As Object
Dim fldrname As String
Dim fldrpath As String
Dim sFileType As String
Dim sSourcePath As String
Dim Destination As String
Set fso = CreateObject("scripting.filesystemobject")
sSourcePath = "\\INSURANCE\IT\FileData\Computers\DIPS\"
fldrname = Worksheets("Applications").Range("A2").Value
fldrpath = "\\INSURANCE\IT\FileData\Computers\DIPS\DIP Archive\" & fldrname
If Not fso.folderexists(fldrpath) Then
fso.createfolder (fldrpath)
End If
End If
I'm now trying to copy all .xlsm files in sSourcePath to the newly created location fldrpath & \ fldrname yet all attempts fail. I'm still fairly new to VBA so any help would be appreciated.
I have heard of .copyfile but i'm not sure how to utilise this in this example.
Thank you in advance.
I do this without filesystemobject.
Sub copyfiles()
Dim source_file As String, dest_file As String
Dim source_path As String, dest_path As String
Dim i As Long, file_array As Variant
source_path = "\\INSURANCE\IT\FileData\Computers\DIPS"
dest_path = "\\INSURANCE\IT\FileData\Computers\DIPS\DIP Archive"
source_file = Dir(source_path & "\" & "*.xlsm")
Do Until source_file = ""
If Not IsArray(file_array) Then
ReDim file_array(0) As Variant
Else
ReDim Preserve file_array(UBound(file_array) + 1) As Variant
End If
file_array(UBound(file_array)) = source_file
source_file = Dir
Loop
'If new folder is not existed, create it.
If Dir(dest_path, 16) = "" Then MkDir dest_path '16=vbDirectory
For i = LBound(file_array) To UBound(file_array)
FileCopy source_path & "\" & file_array(i), dest_path & "\" & file_array(i)
Next i
End Sub
My take on that
Sub copyFiles()
Dim fldrname As String, fldrpath As String, sFileType As String
Dim sSourcePath As String, Destination As String
Dim fso As Object, fFolder As Object, fFile As Object
Set fso = CreateObject("scripting.filesystemobject")
sSourcePath = "\\SourcePath" '"\\INSURANCE\IT\FileData\Computers\DIPS\"
fldrname = "data\" 'Worksheets("Applications").Range("A2").Value
fldrpath = "\\SourcePath\Archive\" & fldrname '"\\INSURANCE\IT\FileData\Computers\DIPS\DIP Archive\" & fldrname
If Not fso.folderexists(fldrpath) Then
fso.createfolder (fldrpath)
End If
Set fFolder = fso.GetFolder(sSourcePath)
For Each fFile In fFolder.Files
'If Not (fso.FileExists(fldrpath & fFile.Name)) Then fFile.Copy fldrpath, Overwritefiles:=False
fFile.Copy fldrpath, Overwritefiles:=True
Next fFile
End Sub
I am having problems with my code since it only works in the specific folders but not in all subfolders inside the particular folder.
Could someone please helps to make the code works to all subfolders inside that specific folder? :)
These are my code:
Sub Execute1()
Dim monthstr As String
Dim year As String
Dim monthtext As String
Dim prevmonth As String
Dim prevmonthtext As String
year = Range("D8").Text
monthstr = Trim(Range("D9").Text)
monthtext = Trim(Range("D10").Text)
prevmonth = Trim(Range("D11").Text)
prevmonthtext = Trim(Range("D12").Text)
prevyear = Trim(Range("D13").Text)
'confirmation box before running macro//////////////////////////////////////////////////////////////////////////////////////
response = MsgBox("Are you sure the settings are correct?", vbYesNo, "Confirmation")
If response = vbNo Then
Exit Sub
End If
'optimize macro speed///////////////////////////////////////////////////////////////////////////////////////////////////////////
Call Optimize
'finding the correct path (month)//////////////////////////////////////////////////////////////////////////////////////////
Dim myfile As String
Dim mypath As String
Dim newpath As String
mypath = "C:\Users\praseirw\Desktop\Tes CC\" & prevyear & "\SC\" & prevmonth & " " & prevmonthtext & "\"
myfile = Dir(mypath & "*.xlsx")
newpath = "C:\Users\praseirw\Desktop\Tes CC\" & year & "\SC\" & monthstr & " " & monthtext & "\"
'loop through all files in specified month//////////////////////////////////////////////////////////////////////////////////
Dim root As Workbook
Dim rng As Range
Dim wb As Workbook
Dim ws As Worksheet
Set root = Workbooks("CC Reports Center.xlsm")
Set rng = root.Worksheets("Settings").Range("H7:H14")
Do While myfile <> ""
Set wb = Workbooks.Open(mypath & myfile)
For Each ws In wb.Worksheets
rng.Copy
With ws.Range("D1")
.PasteSpecial xlPasteFormulas
End With
Next ws
Dim oldname As String
Dim newname As String
Dim wbname As String
oldname = wb.Name
wbname = Mid(oldname, 9)
newname = year & "_" & monthstr & "_" & wbname
wb.SaveAs Filename:=newpath & newname
wb.Close
Set wb = Nothing
myfile = Dir
Loop
Application.CutCopyMode = False
MsgBox "Task Complete!"
'reset macro optimization settings//////////////////////////////////////////////////////////////////////////////////////////////
Call ResetOptimize
End Sub
Here's one way to do it with the Dir function. If you want something a little more elegant you may want to consider using a FileSystemObject. (Note that to view Debug.Print output you have to enable the immediate window from under view.)
Sub test()
Dim root As String
root = "C:\"
Dim DC As New Collection
s = Dir(root & "*", vbDirectory)
Do Until s = ""
DC.Add s
s = Dir
Loop
For Each D In DC
Debug.Print D
On Error Resume Next: s = Dir(root & D & "\*.xl*"): On Error GoTo 0
Do Until s = ""
Debug.Print " " & s
s = Dir
Loop
Next
End Sub
Here's an example of how to do this with a FileSystemObject. Note that my code is a little sloppy with "On error resume next" to protect against access denied or other errors. Realistically you may want to consider incorporating better error handling, but that's another topic. Using a FileSystemObject is more powerful than Dir because Dir only returns a string, while FileSystemObject lets you work with files and folders as actual objects, which are much more powerful.
Sub test()
'You can use "CreateObject..." to add a FileSystemObject from the Scipting Library
'Alternatively, you can add a reference to "Microsoft Scripting Runtime"
'allowing you to directly declare a filesystemobject and access related intellisense
Set fso = CreateObject("Scripting.FileSystemObject")
Set Folder = fso.GetFolder("C:\")
For Each SubFolder In Folder.SubFolders
Debug.Print SubFolder.Name
On Error Resume Next
For Each File In SubFolder.Files
Debug.Print " " & File.Name
Next
On Error GoTo 0
Next
End Sub