I have files and folders with same name how i can move this files to folder has same name.
In VBA you can move files between folders with Scripting.FileSystemObject.
To do that, you can somenthing like in this Sub:
Sub MoveFiles()
Dim FSO As Object
Dim SourceFileName As String, DestFileName As String
Set FSO = CreateObject("Scripting.Filesystemobject")
SourceFileName = "C:\Users\myUser\Documents\Test.xlsx"
DestFileName = "C:\Users\myUser\Desktop\Test.xlsx"
FSO.MoveFile Source:=SourceFileName, Destination:=DestFileName
End Sub
Hope this helps.
Related
I'm looking for a VBA code to loop through all subfolders of my foldfolder, export each Powerpoint files which begin with "EN" in these subfolders to a pdf file, this new pdf files should be saved in another folder.
Thank you for your help.
'It's VBA code that i tried to make
Sub loopthrough ()
Dim folder As Object
Dim fo As String
Dim SubFolders As Object
Dim CurrFile As Object
Dim foldest As String
Dim Chemin As String 'path'
Dim fichier As String 'file'
Set fso = CreateObject("Scripting.FileSystemObject")
fo = "C:\Users\samiess\Desktop\resu\"
Set folder = fso.GetFolder(fo)
Set SubFolders = folder.SubFolders
Dim ppAPP As PowerPoint.Application, ppPres As
PowerPoint.Presentation
Set ppAPP = CreateObject("Powerpoint.Application")
AppActivate Application.Caption
foldest = "C:\Users\samiess\Desktop\resu\EN\"
For Each SubFolders In SubFolders
Set CurrFile = SubFolders.Files
For Each CurrFile In CurrFile
If CurrFile Like "*EN*" Then
chemin = CurrFile
fichier = Dir(chemin)
End If
Next
Do While Len(fichier) > 0
Set ppPres = ppAPP.Presentations.Open(fo & fichier)
ppPres.ExportAsFixedFormat foldest & chemin,_
FixedFormatType:=ppFixedFormatTypePDF
ppPres.Close
fichier = Dir()
Loop
Next
End sub
You can use the following piece of code to create an array with all files names you need. Sorry for the author, but I don't know who it is. (not me anyway).
Private Function RFilesList(fileMask As String) As Variant
'recursive file list
'returns an array with full filenames, including subfolders
'fileMask must include folder and file mask, like this: "c:\test\*.xl*"
RFilesList = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & fileMask & """ /s/b").stdout.readall, vbCrLf)
End Function
I have a main Excel file and CSV data in several subfolders. I want now to load the CSVs from one subfolder, start another VBA-Script and then go to the next subfolder.
Example:
MyExcelFile.xlsm
Country 1
../Data1.csv
../Data2.csv
Country 2
../Data3.csv
../Data4.csv
Country1 Report1.csv Report2.csv Country2
Report3.csv Report4.csv
Load all CSVs from Country1, generate a Report, then go to Country2 and generate the report with this data.
Here is my VBA to load the CSVs (thanks to the Author mentioned):
Sub ImportCSVs()
'Author: Jerry Beaucaire
'Date: 8/16/2010
'Summary: Import all CSV files from a folder into separate sheets
Dim fPath As String
Dim fCSV As String
Dim wbCSV As Workbook
Dim wbMST As Workbook
Set wbMST = ThisWorkbook
fPath = (Application.ActiveWorkbook.Path & "\") 'path to CSV files, include the final \
Application.ScreenUpdating = False 'speed up macro
Application.DisplayAlerts = False 'no error messages, take default answers
fCSV = Dir(fPath & "*.txt") 'start the CSV file listing
On Error Resume Next
Do While Len(fCSV) > 0
Set wbCSV = Workbooks.Open(fPath & fCSV, xlDelimited, Delimiter:=",", Format:=6, Local:=False) 'open a CSV file
wbMST.Sheets(ActiveSheet.Name).Delete 'delete sheet if it exists
ActiveSheet.Move After:=wbMST.Sheets(wbMST.Sheets.Count) 'move new sheet into Mstr
Columns.AutoFit 'clean up display
fCSV = Dir 'ready next CSV
Loop
Application.ScreenUpdating = True
Set wbCSV = Nothing
End Sub
Can anyone explain me, how I can go to all Subfolders and hand over the "Subfolder-Name" the the ImportCSVs-CSV? I was looking for this the whole afternoon, but couldn't find an answer.
Thank you so much in advance :-)
Thank you so much for your help. I managed to do exactly what i wanted with the following code:
Sub RunAll()
Dim Fso As Object, objFolder As Object, objSubFolder As Object, tempFolder
As Object
Dim FromPath As String
Dim fpath As String
Dim FileInFolder As Object
Dim ToPath As String
Dim temporaryFolder As String
temporaryFolder = "Temp"
fpath = (Application.ActiveWorkbook.Path & "\")
FromPath = fpath
ToPath = fpath & temporaryFolder & "\"
Set Fso = CreateObject("Scripting.filesystemobject")
Set objFolder = Fso.GetFolder(FromPath)
'clean Masterfolder first
Set tempFolder = Fso.GetFolder(ToPath)
'loop through each subfolders
For Each objSubFolder In objFolder.subfolders
For Each File In tempFolder.Files
File.Delete
Next File
For Each FileInFolder In objSubFolder.Files
If FileInFolder.Name Like "*REPORT*.txt" Then 'criteria
FileInFolder.Copy ToPath
End If
Next FileInFolder
'Check if folder is empty
If Dir(ToPath & "*.*") = "" Then
Else
Call ImportCSVs
Call ImportData
Call PrintPDF
End If
Next objSubFolder
Call CloseFile
End Sub
Creating objects is the concept here. My way is loop through all CSV files in the target folder(includes its subfolders) , and then import those CSV meet my criteria into a new temp folder.
Then you can use your current code to load all CSV to mastersheet, rename and control the temp folder whatever. Hope this helps.
Dim Fso As Object, objFolder As Object, objSubFolder As Object, tempFolder As Object
Dim FromPath As String
Dim FileInFolder As Object
Dim ToPath As String
ToPath = "V:\MasterFolder\"
FromPath = "V:\TargetFolder\"
Set Fso = CreateObject("Scripting.filesystemobject")
'clean Masterfolder first
Set tempFolder = Fso.GetFolder(ToPath)
For Each File In tempFolder.Files
File.Delete
Next File
'loop through each subfolders
For Each objSubFolder In objFolder.subfolders
For Each FileInFolder In objSubFolder.Files
If FileInFolder.Name Like "*DATA*" Then 'criteria
FileInFolder.Copy ToPath
End If
Next FileInFolder
Next objSubFolder
This is what I have so far, might be good might not haha!
I have been trying to save a word document to about 400+ folders without having to go through them all, can this be done through VB Macros? I got it working to just save it to the directory, but I cannot save it to all the Subfolders.
Dim FileSystem As Object
Dim HostFolder As String
Sub DoFolder(folder)
HostFolder = ("H:\test2")
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
Dim SubFolder
For Each SubFolder In folder.SubFolders
DoFolder SubFolder
Next
Dim File
For Each File In folder.Files
Set FileSystem = CreateObject("Scripting.FileSystemObject")
' Operate on each file
ActiveDocument.Save
Next
End Sub
I recommended reading: Chip Pearson -Recursion And The FileSystemObject
Make a recursive subroutine to iterate over all the subfolders (and their subfolders) in the root directory.
getAllSubfolderPaths: returns an array that lists all the sub folders in a folder.
Function getAllSubfolderPaths(FolderPath As String, Optional FSO As Object, Optional List As Object)
Dim fld As Object
If FSO Is Nothing Then
Set FSO = CreateObject("Scripting.Filesystemobject")
Set List = CreateObject("SYstem.Collections.ArrayList")
End If
List.Add FolderPath
For Each fld In FSO.GetFolder(FolderPath).SubFolders
getAllSubfolderPaths fld.Path, FSO, List
Next
getAllSubfolderPaths = List.ToArray
End Function
Test
Sub Test()
Const RootFolder As String = "C:\Users\Owner\Pictures"
Const SourcePath As String = "C:\Users\Owner\Documents\Youcam"
Const SourceFileName As String = "Capture.PNG"
Dim fld As Variant, FolderArray As Variant
Dim Destination As String, Source As String
FolderArray = getAllSubfolderPaths(RootFolder)
For Each fld In FolderArray
Destination = fld & "\" & SourceFileName
Source = SourcePath & "\" & SourceFileName
'Delete old copy of file
If Destination <> Source And Len(Dir(Destination)) Then Kill Destination
VBA.FileCopy Source:=Source, Destination:=Destination
Next
End Sub
Gotta love auditing requirements... You're basically on the right path, but you really only need one FileSystemObject. About the only errors I see are that you need the .Path of the folder here...
For Each SubFolder In folder.SubFolders
DoFolder SubFolder.Path '<---Here.
Next
...and you don't need to loop through all the files here (you may be overthinking this one a bit):
For Each File In folder.Files
Set FileSystem = CreateObject("Scripting.FileSystemObject")
' Operate on each file
ActiveDocument.Save
Next
Also, I'd suggest using early binding instead of late binding (although the example below can easily be switched). I'd do something a bit more like this:
Private Sub SaveDocToAllSubfolders(targetPath As String, doc As Document, _
Optional root As Boolean = False)
With New Scripting.FileSystemObject
Dim current As Scripting.folder
Set current = .GetFolder(targetPath)
If Not root Then
doc.SaveAs .BuildPath(targetPath, doc.Name)
End If
Dim subDir As Scripting.folder
For Each subDir In current.SubFolders
SaveDocToAllSubfolders subDir.Path, doc
Next
End With
End Sub
The root flag is just whether or not to save a copy in the host folder. Call it like this:
SaveDocToAllSubfolders "H:\test2", ActiveDocument, True
can you help me?
i want a macro vba that search for a SPECIFIC subfolder for example (Xfolder) between all the folders and subfolders that exist and move their files.
P:\Desktop\Folder1\subfolder\SUBFOLDER1\Xfolder
I'm using the VBA Scripting Runtime objects
Set oSourceFolder = fso.GetFolder(source)
If Dir(destinationFolder, 16) = "" Then MkDir (destinationFolder)
For Each oFile In oFolder.Files
If Dir(destinationFolder,16) = "" Then
fso.MoveFile oFile.Path, destinationFolder
End If
Next oFile
fso.DeleteFolder oFolder.Path
Next oFolder
Here's a solution:
Dim fsoFileSystem As New FileSystemObject
Dim foFolder As Folder, foSubFolder As Folder
Dim fFile As File
Dim strStartFolder As String, strMoveFolder As String, strTargetFolder As String
strStartFolder = "\\A\B\C"
strMoveFolder = "SearchFolder"
strTargetFolder = "\\B\D\E"
Set foFolder = fsoFileSystem.GetFolder(strStartFolder)
For Each foSubFolder In foFolder.SubFolders
If foSubFolder.Name = strMoveFolder Then
For Each fFile In foSubFolder.Files
fsoFileSystem.MoveFile fFile, strTargetFolder & "\"
Next
End If
Next
strStartFolder is the folder to Screen for subfolders.
strMoveFolder is the name of the Folder to look for.
strTargetFolder is the Folder to where all the strMoveFolder's files shall be moved.
To found some folder use something like this
Sub findFolder()
Dim searchFolderName As String
searchFolderName = "somePath"
Dim FileSystem As Object
Set FileSystem = CreateObject("Scripting.FileSystemObject")
doFolder FileSystem.getFolder(searchFolderName)
End Sub
Sub doFolder(Folder)
Dim subFolder
On Error Resume Next
For Each subFolder In Folder.subfolders
If Split(subFolder, "\")(UBound(Split(subFolder, "\"))) = "testFolder" Then
MsgBox "gotcha"
End
End If
doFolder subFolder
Next subFolder
End Sub
And then you can do whatever with that folder and its content. So with i little use of google (one maybe two words) you can achieve what you wana
I am unzipping a file in a folder, and saving in a new location. How do I rename that file immediately after unzipping it? After unzipping I will have a file like 1234_data.csv, how do I rewrite that as whatiwant.csv ?
I am aware I need to use a line such as Name oldfile As NewFileName
Sub Unzip1(str_FILENAME As String)
Dim oApp As Object
Dim Fname As Variant
Dim FnameTrunc As Variant
Dim FnameLength As Long
'Fname = str_FILENAME 'Commented out to show example file name
Fname = "file.zip"
FnameLength = Len(Fname)
If Fname = False Then
'Do nothing
Else
'Extract the files into the newly created folder
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace("C:\Users\Andrew\folder").CopyHere oApp.NameSpace(Fname).Items
DoEvents
End If
End Sub
strPath = “c:\tempzips\”
Fname = "new_file_name.zip"
If Len(Fname) Then
Name strPath + "original.zip" As strPath + Fname
End If
Alternate based on comment
Sub post_unzip(str_just_unzipped_filename As String, str_new_filename As String)
str_path = "c:\thepathtothezips\"
Name strpath + str_just_unzipped_filename As strpath + str_new_filename
End Sub