VBA - How to open folder without knowing the full name - excel

I'm trying to open a folder where I don't know the full path.
For example, the parent folder dir is "D:\Documents" and the folder I want to open is called "22.111 - PROJECT_NAME", where I know the code, but don't know the name. I've tried with "*", but no luck.
Sub OpenFolder()
On Error GoTo Err_cmdExplore_Click
Dim Code As String
Code = Range("A1").Value
GoToFolder = "C:\Windows\explorer.exe D:\Documents\" & Code & "*"
Call Shell(GoToFolder, 1)
Exit_cmdExplore_Click:
Exit Sub
Err_cmdExplore_Click:
MsgBox ("Pasta não encontrada")
Resume Exit_cmdExplore_Click
End Sub

Found the answer on another forum (mrexcel.com), leaving it below for anyone that faces the same problem:
Public Sub Find_and_Open_Folder()
Dim Code As String
Dim targetFolder As String
Code = Range("A1").Value
targetFolder = Dir("D:\Documents\" & Code & "*", vbDirectory)
If targetFolder <> vbNullString Then
Shell "explorer.exe """ & "D:\Documents\" & targetFolder & """", vbNormalFocus
Else
MsgBox "Folder matching D:\Documents\" & Code & "* not found"
End If
End Sub

With the parent folder available and the knowledge that the subfolder starts with 22.111, you could loop through all subfolders in the parent folder, and list all the potential matches using InStr. Example of how you might do this:
Sub CodeSnippet()
Dim myFolderName As String
'GetFolders returns array
Dim folderNamesWithPattern As Variant
'searching for "22.111" at 1st pos in string of potential subfolder
folderNamesWithPattern = GetFolders("D:\Documents", "22.111", 1)
If UBound(folderNamesWithPattern) > 0 Then
'more than one folder that meets your pattern:
'decide what to do
Else
'only one entry in array, this is your folder or if "" then ( no such folder | parent folder does not exist )
myFolderName = folderNamesWithPattern(0)
End If
End Sub
Function GetFolders(strDirectory As String, pattern As String, position As Long) As Variant
Dim objFSO As Object
Dim objFolders As Object
Dim objFolder As Object
'create filesystem obj
Set objFSO = CreateObject("Scripting.FileSystemObject")
'create folder obj and access subfolders property
On Error GoTo errorHandler
Set objFolders = objFSO.GetFolder(strDirectory).SubFolders
'dim array for matches
Dim arrFolderNames() As Variant
arrFolderNames = Array()
'loop through all folders
For Each objFolder In objFolders
'InStr() returns 0 if not found | index 1st char in string if found
If InStr(objFolder.Name, pattern) = 1 Then
'add match to array
ReDim Preserve arrFolderNames(UBound(arrFolderNames) + 1)
arrFolderNames(UBound(arrFolderNames)) = objFolder.Name
End If
Next objFolder
'assign array for return
GetFolders = arrFolderNames
errorHandler:
If objFolders Is Nothing Then
'parent folder does not exist
GetFolders = Array("")
ElseIf UBound(arrFolderNames) = -1 Then
'we never found a subfolder that starts with pattern
GetFolders = Array("")
End If
End Function
If you want to use RegEx, you might want to look at How do i use regex using instr in VBA.

Explore a Folder Using Workbook.FollowHyperlink
Workbook.FollowHyperlink method (MSDocs)
A Known Worksheet in the Workbook Containing This Code (ThisWorkbook)
Sub ExploreFolder()
Const iFolderPath As String = "D:\Documents\"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Dim Code As String: Code = CStr(ws.Range("A1").Value)
Dim dFolderPattern As String: dFolderPattern = iFolderPath & Code & "*"
Dim dFolder As String: dFolder = Dir(dFolderPattern, vbDirectory)
If Len(dFolder) > 0 Then
wb.FollowHyperlink iFolderPath & dFolder
Else
MsgBox "A folder matching the pattern '" & dFolderPattern _
& "' was not found.", vbCritical, "Explore Folder"
End If
End Sub
ActiveSheet (not recommended)
Sub ExploreFolderActiveSheet()
Const iFolderPath As String = "D:\Documents\"
Dim ws As Worksheet: Set ws = ActiveSheet
Dim Code As String: Code = CStr(ws.Range("A1").Value)
Dim dFolderPattern As String: dFolderPattern = iFolderPath & Code & "*"
Dim dFolder As String: dFolder = Dir(dFolderPattern, vbDirectory)
If Len(dFolder) > 0 Then
ws.Parent.FollowHyperlink iFolderPath & dFolder
Else
MsgBox "A folder matching the pattern '" & dFolderPattern _
& "' was not found.", vbCritical, "Explore Folder"
End If
End Sub

Related

Renaming Files in directory not only a folder

I am working on a project in excel, where I am renaming multiple files.
Fow now I am using this code
Sub RenameFiles()
Dim xDir As String
Dim xFile As String
Dim xRow As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then
xDir = .SelectedItems(1)
xFile = Dir(xDir & Application.PathSeparator & "*")
Do Until xFile = ""
xRow = 0
On Error Resume Next
xRow = Application.Match(xFile, Range("A:A"), 0)
If xRow > 0 Then
Name xDir & Application.PathSeparator & xFile As _
xDir & Application.PathSeparator & Cells(xRow, "G").Value
End If
xFile = Dir
Loop
End If
End With
End Sub
which lets me change the names of the files in one specific folder, but I would like to be able to pick the main folder containing subfolders and it would change all the names corresponding with names I have made in my excel sheet.
I’m sure you are aware that renaming files if go wrong can have very serious, sometimes even catastrophic consequences, with that been said I hope that all necessary step to avoid any of those problems have been taken.
Data and Code:
It seems that columns A and G contain the "old" and "new" names of the files (excluding the path), and that’s the reason of asking the user for the path and the possibility of running the renaming of the files for subfolders as well.
The code posted compares every file in the folders (and subfolder as expected) against the list of files in the data, which could be time consuming.
Also, I’ll would suggest to have a track of what files have been renamed, so in case of any error, this allows to easily track back and undo what could have be an error.
Solution Proposed
The solution proposed below uses the FileSystemObject object which provides a robust access to the machine file system, you can interact with it in two manners: Early and Late Binding (Visual Basic). These procedures use late binding, to use early binding see How do I use FileSystemObject in VBA?
Folders_ƒGet_From_User: A function that ask the user to select the folder and to process or not subfolders. It returns a list of the subfolder selected (names only), excluding folders with no files.
Files_Get_Array: Creates and array with all the Filenames to be processed (Old & New)
Files_ƒRename: This function renames all files found in any of the folders from the list obtained from point 1. These procedure instead of validating every file present in the subfolders against the list, check if the files in the list Exist in any folder, and if so passes to the function File_ƒRename_Apply that does the renaming and returns the result, allowing the creation of the “Audit Track” array. It returns an array with the results of all the files names in the list in all the folders list ( from point 1 and 2) respectively.
File_Rename_Post_Records: Creates a worksheet named FileRename(Track) (if not present) to post the Audit Track of the results of the Files_ƒRename function.
All of them are called from the procedure: Files_Rename
Let me know of any questions you might have regarding the resources used.
Option Explicit
Private Const mk_Wsh As String = "FileRename(Track)"
Private Const mk_MsgTtl As String = "Files Rename"
Private mo_Fso As Object
…
Sub Files_Rename()
Dim aFolders() As String, aFiles As Variant
Dim aRenamed As Variant
Set mo_Fso = CreateObject("Scripting.FileSystemObject")
If Not (Folders_ƒGet_From_User(aFolders)) Then Exit Sub
Call Files_Get_Array(aFiles)
If Not (Files_ƒRename(aRenamed, aFolders, aFiles)) Then
Call MsgBox("None file was renamed", vbInformation, mk_MsgTtl)
Exit Sub
End If
Call File_Rename_Post_Records(aFiles, aRenamed)
Call MsgBox("Files were renamed" & String(2, vbLf) _
& vbTab & "see details in sheet [" & mk_Wsh & "]", vbInformation, mk_MsgTtl)
End Sub
…
Private Function Folders_ƒGet_From_User(aFolders As Variant) As Boolean
Dim aFdrs As Variant
Dim oFdr As Object, sFolder As String, blSubFdrs As Boolean
Erase aFolders
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show <> -1 Then Exit Function
sFolder = .SelectedItems(1)
End With
If MsgBox("Do you want to include subfolders?", _
vbQuestion + vbYesNo + vbDefaultButton2, _
mk_MsgTtl) = vbYes Then blSubFdrs = True
Set oFdr = mo_Fso.GetFolder(sFolder)
Select Case blSubFdrs
Case False
If oFdr.Files.Count > 0 Then
aFdrs = aFdrs & "|" & oFdr.Path
Else
MsgBox "No files found in folder:" & String(2, vbLf) & _
vbTab & sFolder & String(2, vbLf) & _
vbTab & "Process is being terminated.", _
vbInformation, mk_MsgTtl
Exit Function
End If
Case Else
Call SubFolders_Get_Array(aFdrs, oFdr)
If aFdrs = vbNullString Then
MsgBox "No files found in folder & subfolders:" & String(2, vbLf) & _
vbTab & sFolder & String(2, vbLf) & _
vbTab & "Process is being terminated.", _
vbInformation, mk_MsgTtl
Exit Function
End If
End Select
Rem String To Array
aFdrs = Mid(aFdrs, 2)
aFdrs = Split(aFdrs, "|")
aFolders = aFdrs
Folders_ƒGet_From_User = True
End Function
…
Private Sub SubFolders_Get_Array(aFdrs As Variant, oFdr As Object)
Dim oSfd As Object
With oFdr
If .Files.Count > 0 Then aFdrs = aFdrs & "|" & .Path
For Each oSfd In .SubFolders
Call SubFolders_Get_Array(aFdrs, oSfd)
Next: End With
End Sub
…
Private Sub Files_Get_Array(aFiles As Variant)
Dim lRow As Long
With ThisWorkbook.Sheets("DATA") 'change as required
lRow = .Rows.Count
If Len(.Cells(lRow, 1).Value) = 0 Then lRow = .Cells(lRow, 1).End(xlUp).Row
aFiles = .Cells(2, 1).Resize(-1 + lRow, 7).Value
End With
End Sub
…
Private Function Files_ƒRename(aRenamed As Variant, aFolders As Variant, aFiles As Variant) As Boolean
Dim vRcd As Variant: vRcd = Array("Filename.Old", "Filename.New")
Dim blRenamed As Boolean
Dim oDtn As Object, aRcd() As String, lRow As Long, bFdr As Byte
Dim sNameOld As String, sNameNew As String
Dim sFilename As String, sResult As String
aRenamed = vbNullString
Set oDtn = CreateObject("Scripting.Dictionary")
vRcd = Join(vRcd, "|") & "|" & Join(aFolders, "|")
vRcd = Split(vRcd, "|")
oDtn.Add 0, vRcd
With mo_Fso
For lRow = 1 To UBound(aFiles)
sNameOld = aFiles(lRow, 1)
sNameNew = aFiles(lRow, 7)
vRcd = sNameOld & "|" & sNameNew
For bFdr = 0 To UBound(aFolders)
sResult = Chr(39)
sFilename = .BuildPath(aFolders(bFdr), sNameOld)
If .FileExists(sFilename) Then
If File_ƒRename_Apply(sResult, sNameNew, sFilename) Then blRenamed = True
End If
vRcd = vRcd & "|" & sResult
Next
vRcd = Mid(vRcd, 2)
vRcd = Split(vRcd, "|")
oDtn.Add lRow, vRcd
Next: End With
If Not (blRenamed) Then Exit Function
aRenamed = oDtn.Items
aRenamed = WorksheetFunction.Index(aRenamed, 0, 0)
Files_ƒRename = True
End Function
…
Private Function File_ƒRename_Apply(sResult As String, sNameNew As String, sFileOld As String) As Boolean
With mo_Fso.GetFile(sFileOld)
sResult = .ParentFolder
On Error Resume Next
.Name = sNameNew
If Err.Number <> 0 Then
sResult = "¡Err: " & Err.Number & " - " & Err.Description
Exit Function
End If
On Error GoTo 0
End With
File_ƒRename_Apply = True
End Function
…
Private Sub File_Rename_Post_Records(aFiles As Variant, aRenamed As Variant)
Const kLob As String = "lo.Audit"
Dim blWshNew As Boolean
Dim Wsh As Worksheet, Lob As ListObject, lRow As Long
Rem Worksheet Set\Add
With ThisWorkbook
On Error Resume Next
Set Wsh = .Sheets(mk_Wsh)
On Error GoTo 0
If Wsh Is Nothing Then
.Worksheets.Add After:=.Sheets(.Sheets.Count)
Set Wsh = .Sheets(.Sheets.Count)
blWshNew = True
End If: End With
Rem Set ListObject
With Wsh
.Name = mk_Wsh
.Activate
Application.GoTo .Cells(1), 1
Select Case blWshNew
Case False
Set Lob = .ListObjects(kLob)
lRow = 1 + Lob.ListRows.Count
Case Else
With .Cells(2, 2).Resize(1, 4)
.Value = Array("TimeStamp", "Filename.Old", "Filename.New", "Folder.01")
Set Lob = .Worksheet.ListObjects.Add(xlSrcRange, .Resize(2), , xlYes)
Lob.Name = "lo.Audit"
lRow = 1
End With: End Select: End With
Rem Post Data
With Lob.DataBodyRange.Cells(lRow, 1).Resize(UBound(aRenamed), 1)
.Value = Format(Now, "YYYYMMDD_HHMMSS")
.Offset(0, 1).Resize(, UBound(aRenamed, 2)).Value = aRenamed
.CurrentRegion.Columns.AutoFit
End With
End Sub
Renaming Files (Subfolders)
Not nearly enough tested.
You better create a copy of the folder where it should run to avoid losing files.
It will write all files in the folder and its subfolders to a dictionary object whose keys (file paths) will be checked against the file paths in column A. If matched, the files will be renamed to the name in column G with the same file path.
It checks each new file path only against the file paths in the dictionary before renaming.
It will fail if a file name is not valid.
Copy the complete code to a standard module, e.g. Module1.
Adjust the values in the constants section of the first procedure.
Run only the first procedure, the rest is being called by it.
The Code
Option Explicit
Sub renameFiles()
' Define constants.
Const wsName As String = "Sheet1"
Const FirstRow As Long = 2
Dim Cols As Variant
Cols = Array("A", "G")
Dim wb As Workbook
Set wb = ThisWorkbook
' Define worksheet.
Dim ws As Worksheet
Set ws = wb.Worksheets(wsName)
' Define Lookup Column Range.
Dim rng As Range
Set rng = defineColumnRange(ws, Cols(LBound(Cols)), FirstRow)
' Write values from Column Ranges to jagged Column Ranges Array.
Dim ColumnRanges As Variant
ColumnRanges = getColumnRanges(rng, Cols)
' Pick a folder.
Dim FolderPath As String
FolderPath = pickFolder
' Define a Dictionary object.
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
' Write the paths and the names of the files in the folder
' and its subfolders to the Dictionary.
Set dict = getFilesDictionary(FolderPath)
' Rename files.
Dim RenamesCount As Long
RenamesCount = renameColRngDict(ColumnRanges, dict)
' Inform user.
If RenamesCount > 0 Then
MsgBox "Renamed " & RenamesCount & " file(s).", vbInformation, "Success"
Else
MsgBox "No files renamed.", vbExclamation, "No Renames"
End If
End Sub
Function defineColumnRange(Sheet As Worksheet, _
ColumnIndex As Variant, _
FirstRowNumber As Long) _
As Range
Dim rng As Range
Set rng = Sheet.Cells(FirstRowNumber, ColumnIndex) _
.Resize(Sheet.Rows.Count - FirstRowNumber + 1)
Dim cel As Range
Set cel = rng.Find(What:="*", _
LookIn:=xlFormulas, _
SearchDirection:=xlPrevious)
If Not cel Is Nothing Then
Set defineColumnRange = rng.Resize(cel.Row - FirstRowNumber + 1)
End If
End Function
Function getColumnRanges(ColumnRange As Range, _
BuildColumns As Variant) _
As Variant
Dim Data As Variant
ReDim Data(LBound(BuildColumns) To UBound(BuildColumns))
Dim j As Long
With ColumnRange.Columns(1)
For j = LBound(BuildColumns) To UBound(BuildColumns)
If .Rows.Count > 1 Then
Data(j) = .Offset(, .Worksheet.Columns(BuildColumns(j)) _
.Column - .Column).Value
Else
Dim OneCell As Variant
ReDim OneCell(1 To 1, 1 To 1)
Data(j) = OneCell
Data(1, 1) = .Offset(, .Worksheet.Columns(BuildColumns(j)) _
.Column - .Column).Value
End If
Next j
End With
getColumnRanges = Data
End Function
Function pickFolder() _
As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then
pickFolder = .SelectedItems(1)
End If
End With
End Function
' This cannot run without the 'listFiles' procedure.
Function getFilesDictionary(ByVal FolderPath As String) _
As Object
Dim dict As Object ' ByRef
Set dict = CreateObject("Scripting.Dictionary")
With CreateObject("Scripting.FileSystemObject")
listFiles dict, .GetFolder(FolderPath)
End With
Set getFilesDictionary = dict
End Function
' This is being called only by 'getFileDictionary'
Sub listFiles(ByRef Dictionary As Object, _
fsoFolder As Object)
Dim fsoSubFolder As Object
Dim fsoFile As Object
For Each fsoFile In fsoFolder.Files
Dictionary(fsoFile.Path) = Empty 'fsoFile.Name
Next fsoFile
For Each fsoSubFolder In fsoFolder.SubFolders
listFiles Dictionary, fsoSubFolder
Next
End Sub
' Breaking the rules:
' A Sub written as a function to return the number of renamed files.
Function renameColRngDict(ColumnRanges As Variant, _
Dictionary As Object) _
As Long
Dim Key As Variant
Dim CurrentIndex As Variant
Dim NewFilePath As String
For Each Key In Dictionary.Keys
Debug.Print Key
CurrentIndex = Application.Match(Key, _
ColumnRanges(LBound(ColumnRanges)), 0)
If Not IsError(CurrentIndex) Then
NewFilePath = Left(Key, InStrRev(Key, Application.PathSeparator)) _
& ColumnRanges(UBound(ColumnRanges))(CurrentIndex, 1)
If IsError(Application.Match(NewFilePath, Dictionary.Keys, 0)) Then
renameColRngDict = renameColRngDict + 1
Name Key As NewFilePath
End If
End If
Next Key
End Function

how can i walk on folders and sub-folders and get files with specific file type then copy to another directory in VBA?

I want to copy specific file type(*.SLDDRW) from source to destination,in destination path we have lots of folders and sub-folders .in below code i am trying to walk on any sub folders but unfortunately it didn't work and didn't walk all sub-folders S.O can help me?
Sub copy_specific_files_in_folder()
Dim FSO As Object
Dim sourcePath As String
Dim destinationPath As String
Dim fileExtn As String
sourcePath = "C:\Users\6\"
destinationPath = "C:\Users\"
fileExtn = "*.SLDDRW"
If Right (sourcePath, 1) <> "\" Then
sourcePath = sourcePath & "\"
End If
Set FSO = CreateObject ("scripting.filesystemobject")
If FSO.FolderExists(sourcepath) = False Then
MsgBox sourcePath & " does not exist"
Exit Sub
End If
FSO.CopyFile Source:=sourcePath & fileExtn, Destination :=destinationPath
copy_files_from_subfolders
MsgBox "Your files have been copied from the sub-folders of " & sourcePath
End sub
sub copy_files_from_subfolders()
Dim FSO AS Object , fld As Object
Dim fsoFile As Object
Dim fsoFol As Object
sourcePath = "C:\Users\6\"
targetPath = "C:\Users\"
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, 6) = "sldprt" Then
fsoFile.Copy targetPath
End If
Next
Next
End If
Here's a function that will recursively search a folder and all subfolders for a specific extension and then copy found files to a specified destination:
Sub SearchFoldersAndCopy(ByVal arg_sFolderPath As String, _
ByVal arg_sDestinationFolder As String, _
ByVal arg_sExtension As String)
Dim oFSO As Object
Dim oFolder As Object
Dim oSubFolder As Object
Dim sTest As String
'Test if FolderPath exists
sTest = Dir(arg_sFolderPath, vbDirectory)
If Len(sTest) = 0 Then
MsgBox "Specified folder [" & arg_sFolderPath & "] doesn't exist. Please check spelling or create the directory."
Exit Sub
End If
'Test if Destination exists
sTest = Dir(arg_sDestinationFolder, vbDirectory)
If Len(sTest) = 0 Then
MsgBox "Specified destination [" & arg_sDestinationFolder & "] doesn't exist. Please check spelling or create the directory."
Exit Sub
End If
'FolderPath and Destination both exist, proceed with search and copy
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(arg_sFolderPath)
'Test if any files with the Extension exist in directory and copy if one or more found
sTest = Dir(oFolder.Path & Application.PathSeparator & "*." & arg_sExtension)
If Len(sTest) > 0 Then oFSO.copyfile oFolder.Path & Application.PathSeparator & "*." & arg_sExtension, arg_sDestinationFolder
'Recursively search subfolders
For Each oSubFolder In oFolder.SubFolders
SearchFoldersAndCopy oSubFolder.Path, arg_sDestinationFolder, arg_sExtension
Next oSubFolder
End Sub
Here's an example of how to call it:
Sub tgr()
Dim sStartFolder As String
Dim sDestination As String
Dim sExtension As String
sStartFolder = "C:\Test"
sDestination = "C:\Output\" '<-- The ending \ may be required on some systems
sExtension = "SLDDRW"
SearchFoldersAndCopy sStartFolder, sDestination, sExtension
End Sub

Create folder and subfolder

I have an Excel file with hundreds of Customer names and several article numbers.
I want to check if a folder with selected customer name exists and create a folder if it is missing.
Once the customer folder is found or created, check if there is a folder for each article number and if it is missing, create one.
I found code that seems to do all that and more posted by Scott Holtzman.
I have referenced Microsoft Scripting Runtime as the code requests.
Both of the "If not" statements are marked red and the pop-up window only says "Compile error".
I checked the syntax of "If not" statements and it seems to be correct.
'requires reference to Microsoft Scripting Runtime
Sub MakeFolder()
Dim strComp As String, strPart As String, strPath As String
strComp = Range("A1") ' assumes company name in A1
strPart = CleanName(Range("C1")) ' assumes part in C1
strPath = "C:\Images\"
If Not FolderExists(strPath & strComp) Then
'company doesn't exist, so create full path
FolderCreate strPath & strComp & "\" & strPart
Else
'company does exist, but does part folder
If Not FolderExists(strPath & strComp & "\" & strPart) Then
FolderCreate strPath & strComp & "\" & strPart
End If
End If
End Sub
Function FolderCreate(ByVal path As String) As Boolean
FolderCreate = True
Dim fso As New FileSystemObject
If Functions.FolderExists(path) Then
Exit Function
Else
On Error GoTo DeadInTheWater
fso.CreateFolder path ' could there be any error with this, like if the path is really screwed up?
Exit Function
End If
DeadInTheWater:
MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again."
FolderCreate = False
Exit Function
End Function
Function FolderExists(ByVal path As String) As Boolean
FolderExists = False
Dim fso As New FileSystemObject
If fso.FolderExists(path) Then FolderExists = True
End Function
Function CleanName(strName as String) as String
'will clean part # name so it can be made into valid folder name
'may need to add more lines to get rid of other characters
CleanName = Replace(strName, "/","")
CleanName = Replace(CleanName, "*","")
' etc...
End Function
Take a look at the below example, it shows one of the possible approaches using recursive sub call:
Option Explicit
Sub TestArrays()
Dim aCustomers
Dim aArticles
Dim sCustomer
Dim sArticle
Dim sPath
sPath = "C:\Test"
aCustomers = Array("Customer01", "Customer02", "Customer03", "Customer04", "Customer05")
aArticles = Array("Article01", "Article02", "Article03", "Article04", "Article05")
For Each sCustomer In aCustomers
For Each sArticle In aArticles
SmartCreateFolder sPath & "\" & sCustomer & "\" & sArticle
Next
Next
End Sub
Sub TestFromSheet()
Dim aCustomers
Dim aArticles
Dim i
Dim j
Dim sPath
sPath = "C:\Test"
With ThisWorkbook.Sheets(1)
aCustomers = .Range(.Range("A1"), .Range("A1").End(xlDown)).Value
aArticles = .Range("B1:B10").Value
End With
For i = LBound(aCustomers, 1) To UBound(aCustomers, 1)
For j = LBound(aArticles, 1) To UBound(aArticles, 1)
SmartCreateFolder sPath & "\" & aCustomers(i, 1) & "\" & aArticles(j, 1)
Next
Next
End Sub
Sub SmartCreateFolder(sFolder)
Static oFSO As Object
If oFSO Is Nothing Then Set oFSO = CreateObject("Scripting.FileSystemObject")
With oFSO
If Not .FolderExists(sFolder) Then
SmartCreateFolder .GetParentFolderName(sFolder)
.CreateFolder sFolder
End If
End With
End Sub
Sub TestArrays() checks and creates folders for customers and articles from the hardcoded arrays, and Sub TestFromSheet() gets customers and articles from the first worksheet, as an example customers range from A1 up to the last element, so it should be more than one element there, and articles set to fixed range B1:B10, like shown below:
The StrComp Issue
You cannot use StrComp, its a reserved word, actually a string function. I lost about 15 minutes the other day on this issue.
VBA says: Returns a Variant (Integer) indicating the result of a string comparison.
If you want to shorthand a bunch of that code, use MKDIR to create each level of folder\subfolder with error pass-over.
Option Explicit
Sub main()
Dim pth As String
pth = "c:\test\abc\123\test_again\XYZ\01-20-2019"
'folder may or may not exist
makeFolder pth
'folder definitely exists
End Sub
Sub makeFolder(fldr As String)
Dim i As Long, arr As Variant
'folder may or may not exist
arr = Split(fldr, Chr(92))
fldr = arr(LBound(arr))
On Error Resume Next
For i = LBound(arr) + 1 To UBound(arr)
fldr = Join(Array(fldr, arr(i)), Chr(92))
MkDir fldr
Next i
On Error GoTo 0
'folder definitely exists
End Sub
To rename an existing file to a new location WITH creation of all subdirectories, you can use:
File_Name_OLD = File_Pad_OLD & "Test.txt"
File_Pad_NEW = "e:\temp\test1\test2\test3\"
File_Name_NEW = File_Pad_NEW & "Test.txt"
X = File_Pad_NEW
A = 1
Do Until A = 0
A = InStr(X, "\")
Y = Y & Left(X, A)
X = Mid(X, A + 1)
If Dir(Y, 16) = "" Then MkDir Y
Loop
Name File_Name_OLD As File_Name_NEW
This is creating the new path with subdirectories and renames the old file to the new one.

VBA Applying code for multiple locations

Hello I have a macro that copies files from specific folders to a single folder and I am wondering whether the code I have can be altered to pull multiple files from multiple specified folders within one loop, as now I have to create a new module for every single folder path/file.
I have the following code:
Sub SmplAPP()
Dim FSO As Object
Dim FrFldr As String
Dim ToFldr As String
Dim myVal1 As Variant
Dim myValn As String
myVal1 = InputBox("Please enter today's date in mm-dd format")
myValn = Replace(myVal1, "-", "\")
Range("I1").Value = myValn
FrFldr = "\\xxxf003\sample_data\SAMPLE_REPORTS\APPS\Reports\Regional\SAMPLE_APPLICATION\2017\" & myValn
ToFldr = "C:\Users\sample\Desktop\logs_to_upload"
If Right(FrFldr, 1) = "\" Then
FrFldr = Left(FrFldr, Len(FrFldr) - 1)
End If
If Right(ToFldr, 1) = "\" Then
ToFldr = Left(ToFldr, Len(ToFldr) - 1)
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(FrFldr) = False Then
MsgBox FrFldr & " doesn't exist"
Exit Sub
End If
FSO.CopyFolder Source:=FrFldr, Destination:=ToFldr
Call NextApp
End Sub
Any help would be greatly appreciated!
If you want copy from different folder, you may use collection. I have amended your subroutine:
Sub SmplAPP()
Dim FSO As Object
Dim collFrFldr As New Collection
Dim FrFldr As Variant
Dim ToFldr As String
Dim myVal1 As Variant
Dim myValn As String
myVal1 = InputBox("Please enter today's date in mm-dd format")
myValn = Replace(myVal1, "-", "\")
Range("I1").Value = myValn
collFrFldr.Add "\\xxxf003\sample_data\SAMPLE_REPORTS\APPS\Reports\Regional\SAMPLE_APPLICATION\2017\" & myValn
collFrFldr.Add "\\another folder"
collFrFldr.Add "\\yet another folder"
ToFldr = "c:\Users\u195567\test\"
If Right(ToFldr, 1) = "\" Then
ToFldr = Left(ToFldr, Len(ToFldr) - 1)
End If
Set FSO = CreateObject("scripting.filesystemobject")
For Each FrFldr In collFrFldr
If Right(FrFldr, 1) = "\" Then
FrFldr = Left(FrFldr, Len(FrFldr) - 1)
End If
If FSO.FolderExists(FrFldr) = False Then
MsgBox FrFldr & " doesn't exist"
Exit Sub
End If
FSO.CopyFolder Source:=FrFldr, Destination:=ToFldr
Next FrFldr
Call NextApp
End Sub

How to get poster size in Excel Macro

How to get the size of the posters by using vba excel. I am using windows 7 operating system.
Images are present on some other path. Ex. d:\posterbank\a.jpeg,b.jpeg and excel file contains only names like a.jpeg, b.jpeg.
I want to check if these posters are there if yes need to check size of these.
A = LTrim(RTrim(Sheets(sheetno).Range("m" & rowno).Value))
postername = Left(A, Len(A) - 4) & ".bmp"
If filesys.fileExists(Poster_SPath & "\" & postername) Then
Else: Call appendtofile(vbrLf & "Not found " & Eng_Title & " " & postername, Logfile_Path & "\" & "log.txt")
End If
This should get you started :) I have taken the example of 1 picture, I am sure you can amend it to loop the relevant cells and pick up the values :)
TRIED AND TESTED
'~~> Path where images reside
Const FilePath As String = "C:\Documents and Settings\All Users\Documents\My Pictures\Sample Pictures\"
Sub Sample()
Dim Filename As String
'~~> Replace this with the relevant cell value
Filename = "Sunset.JPG"
'~> Check if file exists
If FileFolderExists(FilePath & Filename) = True Then
'~~> In sheet 2 insert the image temporarily
With Sheets("Sheet2")
.Pictures.Insert(FilePath & Filename).Select
'~~> Get dimensions
MsgBox "Picture demensions: " & Selection.Width & " x " & Selection.Height
'~~> Delete the picture
Selection.Delete
End With
End If
End Sub
Public Function FileFolderExists(strFullPath As String) As Boolean
On Error GoTo EarlyExit
If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
EarlyExit:
On Error GoTo 0
End Function
This Worked for Me
Option Explicit
Type FileAttributes
Name As String
Dimension As String
End Type
Public Function GetFileAttributes(strFilePath As String) As FileAttributes
' Shell32 objects
Dim objShell As Shell32.Shell
Dim objFolder As Shell32.Folder
Dim objFolderItem As Shell32.FolderItem
' Other objects
Dim strPath As String
Dim strFileName As String
Dim i As Integer
' If the file does not exist then quit out
If Dir(strFilePath) = "" Then Exit Function
' Parse the file name out from the folder path
strFileName = strFilePath
i = 1
Do Until i = 0
i = InStr(1, strFileName, "\", vbBinaryCompare)
strFileName = Mid(strFileName, i + 1)
Loop
strPath = Left(strFilePath, Len(strFilePath) - Len(strFileName) - 1)
' Set up the shell32 Shell object
Set objShell = New Shell
' Set the shell32 folder object
Set objFolder = objShell.Namespace(strPath)
' If we can find the folder then ...
If (Not objFolder Is Nothing) Then
' Set the shell32 file object
Set objFolderItem = objFolder.ParseName(strFileName)
' If we can find the file then get the file attributes
If (Not objFolderItem Is Nothing) Then
GetFileAttributes.Dimension = objFolder.GetDetailsOf(objFolderItem, 36)
End If
Set objFolderItem = Nothing
End If
Set objFolder = Nothing
Set objShell = Nothing
End Function
Not tested, but using this as reference, it looks like it should be possible to load the image like this.
set myImg = loadpicture(Poster_SPath & "\" & postername & ".bmp")
And then get the width and height like this.
myImg.height
myImg.width

Resources