Can someone help me with VBA code to rename the subfolder with the part of file name as given below
Folder : C:\Test
Sub folders : C:\Test\a , C:\Test\b , C:\Test\a .... Goes on
It has some file contents and I have to match a file with name starting with VDX_000674 and get last 4 characters and rename the Folder with that.
I have tried the below code but with no use any edits will be appreciated
Sub Rename()
Call Test_Rename("C:\Users\shanmso\Desktop\VN\Output")
End Sub
Sub Test_Rename(MyPath As String)
Dim FileSys As FileSystemObject
Dim objFolder As Folder
Dim objSubFolder As Folder
Dim objFile As File
Dim Riname As String
Set FileSys = CreateObject("Scripting.FileSystemObject")
Set objFolder = FileSys.GetFolder(MyPath)
For Each objFile In objFolder.Files
If Left(objFile.Name, 15) = "DEX-VH_00000374" Then
Riname = Mid(objFile.Name, 17, 3)
Name objFolder As Riname
Exit For
End If
Next objFile
For Each objSubFolder In objFolder.SubFolders
Test_Rename MyPath & "\" & objSubFolder.Name
Next objSubFolder
Set FileSys = Nothing
Set objFolder = Nothing
Set objSubFolder = Nothing
Set objFile = Nothing
End Sub
untested. but I think FreeMan is right Name objFolder As Riname should be something more like this Call MkDir(MyPath & "\" & Riname)
Also I don't think you need the second For Each loop so I removed it. I'm guessing you thought this was actually creating the subfolders, but it isn't. Its easier to just rename the folders in the first For each loop
Sub Test_Rename(MyPath As String)
Dim FileSys As FileSystemObject
Dim objFolder As Folder
Dim objSubFolder As Folder
Dim objFile As File
Dim Riname As String
Set FileSys = CreateObject("Scripting.FileSystemObject")
Set objFolder = FileSys.GetFolder(MyPath)
For Each objFile In objFolder.Files
If Left(objFile.Name, 15) = "DEX-VH_00000374" Then
Riname = Mid(objFile.Name, 17, 3)
Call MkDir(MyPath & "\" & Riname)
Exit For
End If
Next objFile
Set FileSys = Nothing
Set objFolder = Nothing
Set objSubFolder = Nothing
Set objFile = Nothing
End Sub
Related
I am admin to my computer.
I am logged into network.
The below procedure runs and crashes
after line
'XXXXXXXXXXXXXXXXX:
stating the permission is denied, at objFile.Delete.
Why is permission denied?
I am able to delete files and folders from windows explorer.
Why can't the vba program delete it?
Any solutions?
Thanks
Sub RecursiveFolderDelete(MyPath As String)
Dim FileSys As FileSystemObject
Dim objFolder As Folder
Dim objSubFolder As Folder
Dim objFile As File
Set FileSys = CreateObject("Scripting.FileSystemObject")
Set objFolder = FileSys.GetFolder(MyPath)
For Each objFile In objFolder.Files
If Left(objFile.Name, 1) <> "~" And objFile.Name <> ThisWorkbook.Name Then
'XXXXXXXXXXXXXXXXX:
objFile.Delete
End If
Next objFile
Dim Count As Integer
Count = 0
For Each objSubFolder In objFolder.SubFolders
Count = Count + 1
RecursiveFolderDelete MyPath & "\" & objSubFolder.Name
Next objSubFolder
On Error GoTo endx:
If Count = 0 Then
RmDir MyPath
Else
If objFolder.SubFolders.Count = 0 Then
RmDir MyPath
End If
End If
endx:
On Error GoTo 0
Set FileSys = Nothing
Set objFolder = Nothing
Set objSubFolder = Nothing
Set objFile = Nothing
End Sub
I am trying to achieve the following using a VBA macro:
I have multiple .xls files, all of which have just one sheet
In my macro, I want to append all the data from the other files into one sheet, by appending them at the bottom of the document behind each other. I have figured out the iterating through files, but copying and appending data is what is bugging me.
The code I have until now is as follows (missing parts are described within the comments)
Sub Iterate_Files()
Dim Fso As Object, objFolder As Object, objSubFolder As Object
Dim FromPath As String
Dim FileInFolder As Object
FromPath = ActiveWorkbook.Path
Set Fso = CreateObject("Scripting.filesystemobject")
Set objFolder = Fso.GetFolder(FromPath)
For Each objSubFolder In objFolder.subfolders
For Each FileInFolder In objSubFolder.Files
'Copy the data from sheet one of the FileInFolder
'to the end of sheet in this file :/
Next FileInFolder
Next objSubFolder
End Sub
The following code appears to have solved the problem:
Sub Iterate_Files()
Dim Fso As Object, objFolder As Object, objSubFolder As Object
Dim FromPath As String
Dim FileInFolder As Object
FromPath = ActiveWorkbook.Path
Set Fso = CreateObject("Scripting.filesystemobject")
Set objFolder = Fso.GetFolder(FromPath)
Set TargetWb = ActiveWorkbook
R = 0
For Each objSubFolder In objFolder.subfolders
For Each FileInFolder In objSubFolder.Files
Set wbSource = Workbooks.Open(FileInFolder)
wbSource.Worksheets(1).UsedRange.Copy Destination:=TargetWb.Worksheets(2).Cells(R + 1, 1)
R = R + 15
wbSource.Close SaveChanges:=False
Next FileInFolder
Next objSubFolder
End Sub
Private Sub Rokaj_Click()
Iterate_Files
End Sub
I am working with a code which can extract entire path of a pdf files and display of active workbook.
But problem is the extracted files are not hyperlinked i.e. I cant open the files directly on clicking on the that cell. Is there any way it gets automatically hyperlinked so that one click opens the files directly from excel.
Below is the code:
Sub ReadFiles()
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("C1").Value)
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
If Right(objFile.Path, 3) = "pdf" Then
'print file path
Cells(i + 2, 13) = objFile.Path
i = i + 1
End If
Next objFile
End Sub
This should work, replace "WorksheetName" with the name of your worksheet:
Sub ReadFiles()
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("C1").Value)
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
If Right(objFile.Path, 3) = "pdf" Then
'print file path
Cells(i + 2, 13) = objFile.Path
Sheets("WorksheetName").Hyperlinks.Add _
Anchor:= Sheets("WorksheetName").Cells(i + 2, 13), _
Address:= objFile.Path
i = i + 1
End If
Next objFile
End Sub
After you print file path add this: cells(i + 2,13).select ActiveCell.Hyperlinks.Add ActiveCell, ActiveCell
Working on a macro for Outlook 2007 which selects messages in a folder.
In example 1 and 2 below the customers folder is selected, then a specific customer folder is selected. The method to define the location seems clumsy. Is there a cleaner way to do this?
Right clicking on the sub-folder and selecting properties, the path shown is: "\mailbox-name\customers\customer-xyz". Referencing the path this way in a macro doesn't work. Is it possible to reference the folder location in a more direct manner?
Set olNamespace = olApp.GetNamespace("MAPI")
' Example-1, Select folder by name from default PST inbox
Set FolderKeep = _
olNamespace.GetDefaultFolder(olFolderInbox).Folders("customers").Folders("customer-XYZ")
' Example-2, Select folder by mailbox name/folder/subfolder
Set FolderKeep = _
olNamespace.Folders("mailbox-name").Folders("customers").Folders("customer-XYZ")
A method of pulling the folder out of a path is described here.
http://www.outlookcode.com/d/code/getfolder.htm
Private Function GetFolder(strFolderpath As String) As Folder
' The path argument needs to be in quotation marks and
' exactly match the folder hierarchy that the user sees in the Folder List.
'
' NOTE: If any folder name in the path string contains a "\" character,
' this routine will not work,
'
' As the developer do not use this. It hides errors.
'On Error GoTo GetFolder_Error
Dim objNS As Namespace
Dim objFolder As Folder
Dim arrFolders() As String
Dim colFolders As Folders
Dim i As Long
Dim uErrorMsg As String
' Remove leading slashes, if any
Do While Left(strFolderpath, 1) = "\"
'Debug.Print strFolderpath
strFolderpath = Right(strFolderpath, Len(strFolderpath) - 1)
Loop
Debug.Print strFolderpath
arrFolders() = Split(strFolderpath, "\")
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then Exit For
Next
End If
Set GetFolder = objFolder
ExitRoutine:
Set colFolders = Nothing
Set objNS = Nothing
Set objFolder = Nothing
Exit Function
GetFolder_Error:
uErrorMsg = "Err.Number: " & Err.Number & vbCr & "Err.Description: " & Err.Description
MsgBox uErrorMsg
Set GetFolder = Nothing
Resume ExitRoutine
End Function
Private Sub GetFolder_Test()
Dim testFolder As Folder
Set testFolder = GetFolder("\mailbox-name\customers\customer-xyz")
If Not (testFolder Is Nothing) Then testFolder.Display
End Sub
I want to open all of the files in a certain folder and have it print out the names of those files.
I have set up a code that opens the files but I cannot get it to print the name. I have a separate code that will print the name but will only open one file. I'm failing at combining the two together correctly. Any ideas?
Code that opens all Excel files:
‘set path to progress folder
Sub OpenFiles()
Dim MyFolder As String
Dim MyFile As String
MyFolder = “C:\Users\trembos\Documents\TDS\progress"
MyFile = Dir(MyFolder & "\*.xlsx")
Do While MyFile <> ""
Workbooks.Open fileName:=MyFolder & "\" & MyFile
MyFile = Dir
Loop
End Sub
Code that prints one file name:
'set path to TDS_Working
Sub TDS()
Workbooks.Open ("C:\Users\trembos\Documents\TDS\progress")
End Sub
'set up dim
Sub LoopThroughDirectory()
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("C:\Users\trembos\Documents\TDS\progress\")
i = 1
'loop through directory file and print names
For Each objFile In objFolder.Files
'print file name
Cells(i + 1, 1) = objFile.Name
Next objFile
End Sub
This should work smoothly :
Sub LoopThroughDirectory()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim MyFolder As String
Dim Sht As Worksheet
Dim i As Integer
MyFolder = "C:\Users\trembos\Documents\TDS\progress\"
Set Sht = ActiveSheet
'create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'get the folder object
Set objFolder = objFSO.GetFolder(MyFolder)
i = 1
'loop through directory file and print names
For Each objFile In objFolder.Files
If LCase(Right(objFile.Name, 3)) <> "xls" And LCase(Left(Right(objFile.Name, 4), 3)) <> "xls" Then
Else
'print file name
Sht.Cells(i + 1, 1) = objFile.Name
i = i + 1
Workbooks.Open Filename:=MyFolder & objFile.Name
End If
Next objFile
End Sub
You just need to iterate i inside the loop: i=i+1.
‘set path to progress folder
Sub OpenFiles()
Dim MyFolder As String
Dim MyFile As String
ActiveSheet.Unprotect ("password")
MyFolder = “C:\Users\trembos\Documents\TDS\progress"
MyFile = Dir(MyFolder & "\*.xlsx")
i=1
Do While MyFile <> ""
Workbooks.Open fileName:=MyFolder & "\" & MyFile
MyFile = Dir
Cells(i + 1, 1) =Myfile
i=i+1
Loop
ActiveSheet.Protect ("password")
End Sub
Does this not work?