Using 2010 Excel VBA - I need to use look up the image/pdf with the Branch Code as a part of its name at "C:\ECB Test\ECB IR COPY" and paste it at "C:\ECB Test\" RO if it exists. If it doesn't, the program needs to highlight the Branch Code.
(File Name Examples: 28-Kochi-ecb-sdwan completed.pdf, 23 eCB Kozhikode completed.pdf/0036.jpeg)
Having done this manually twice for two other excel sheets (4k+ cells), I decided to Frankenstein a module together and, well, it does not work and I have no idea why.
Sub Sort()
Const SRC_PATH As String = "C:\ECB Test\ECB IR COPY"
Const DEST_PATH As String = "C:\ECB Test"
Dim Row_Number As Integer
Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
Dim Folder_Name As String
Dim Branch_Code As String
Dim Final_Path As Variant
Dim File As String
For Row_Number = 3 To 2465
Branch_Code = Worksheets("WAN RFP").Cells(Row_Number, 2)
Folder_Name = Worksheets("WAN RFP").Cells(Row_Number, 5)
On Error Resume Next
File = Dir(SRC_PATH & "\*" & Branch_Code & "*")
Final_Path = Dir(DEST_PATH & "\" & Folder_Name & "\")
If (Len(File) > 0) Then
Call fso.CopyFile(File, Final_Path)
Else
Cells(Row_Number, 2).Interior.ColorIndex = 6
End If
On Error GoTo 0
DoEvents
Next Row_Number
End Sub
I think its unable to use the Branch Code variable as a wildcard, though I might as well have done something silly somewhere in the code. Can someone please help me out?
The problem is you are using the destination path instead of the source path:
File = Dir(DEST_PATH & "*" & Branch_Code & "*.*")
Change it to
File = Dir(SRC_PATH & "*" & Branch_Code & "*.*")
I have a problem I've been trying to solve for a while now with no luck...!
I have a backup code which saves a copy of a spreadsheet using the application.savecopyas method.
Trouble is, once this is run all the hyperlinks throughout the workbook become invalid as part of the path is removed. Such as this:
CORRECT PATH - file:///\servername\department\project\model\site\comms\filename.pdf
INCORRECT PATH - file:///\servername\department\project\comms\filename.pdf
The problem only occurs when running the following line of code:
ActiveWorkbook.SaveCopyAs FileName:=FullFileName
Where FullFileName is defined earlier in the code by:
FullFileName = FolderPath & "\" & Format(Now, "yyyy-mm-dd_hh-mm-ss") & " - " & FileName & "." & FileExt
Any ideas why the SaveCopyAs would be affecting my hyperlinks in this strange way?
-
FURTHER INFORMATION - Repair Code also does a similar thing:
I also have a fixing code to repair the broken links, essentially this gets the file name and manually combines the correct folder name and filename and assigns this to each hyperlink.
I have noticed this also, sometimes leaves out part of the File Path, sometime it works, othertimes it does not. I don't change anything in the code between runs.
Sub HyperlinkFix_FromCustomer()
j = 0
Dim GetURL As String
For j = 3 To 1000
If IsEmpty(Cells(j, 2)) = False Then
On Error Resume Next
LinkAddress = Sheets("From Customer").Range("B" & j).Hyperlinks(1).Address
If Cells(j, 2).Hyperlinks.Count < 1 Then
'MsgBox j
GoTo Next1
End If
'Sheets("From Customer").Range("W" & j).Value = linkAddress
Inputstring = LinkAddress
'InputString = Sheets("From Customer").Range("W" & j).Value
I = 0
While InStr(I + 1, Inputstring, "\") > 0
I = InStr(I + 1, Inputstring, "\")
Wend
'Extract the folder path
'If No occurence of path separator is found then assign the default directory path
If I = 0 Then
FolderName = "Error - No Folder"
Else
FolderName = Left(Inputstring, I - 1)
End If
'Extracting the file name
FileName = Right(Inputstring, Len(Inputstring) - I)
YearStr = Right(Inputstring, Len(Inputstring) - I + 5)
YearStr = Left(YearStr, 4)
NewDIR = "department\Project\model\site\comms\"
NewDIR = GETNETWORKPATH("D:") & "\" & NewDIR
CorrectAddress = NewDIR & "\" & YearStr & "\" & FileName
Sheets("From Saab").Hyperlinks.Add Anchor:=Sheets("From customer").Range("B" & j), Address:=CorrectAddress, TextToDisplay:=Sheets("From customer").Range("B" & j).Value
End If
Next1:
Next j
End Sub
I just found a solution for this problem.
Go to File --> Info --> Show All Properties --> Hyperlink Base
Write your drive there e.g.
C:\
I am quite new to VBA as I have been using other programming languages.
I am trying to use a combo box to list the latest 2 folders from my path.
I have already been able to select all data from the required path as well as I have sorted this.
I need support to be able to list only the latest 2 folders based on my code but am struggling and require help.
Drivepath = Mid(ThisWorkbook.Path, 1, 2)
On Error Resume Next
filepath = Drivepath & "C:\Users\Documents\Month\" & ThisWorkbook.Sheets("Months"). ComboBox1.Value & "\"
Application.Workbooks.Open (filepath & s_workbook)
Application.Sheets(1).Activate
Dim name
ThisWorkbook.Sheets("Months"). ComboBox1.Clear
Drivepath = Mid(ThisWorkbook.Path, 1,2)
For Each name In ListDirectory(Path:=Drivepath & "C:\Users\Documents\Month”, AttrInclude:=vbDirectory, AttrExclude:=vbSystem Or vbHidden)
If Len(name) > 4 Then
If InStr(name, "list") = 0 Then ThisWorkbook.Sheets("Months"). ComboBox1.AddItem name
End If
Next name
'Sort the list
ComBoList = ThisWorkbook.Sheets("Months"). ComboBox1.List
For X = LBound(ComBoList) To UBound(ComBoList) - 1
For j = X + 1 To UBound(ComBoList)
If ComBoList(X, 0) > ComBoList(j, 0) Then
ComBoTemp = ComBoList(X, 0)
ComBoList(X, 0) = ComBoList(j, 0)
ComBoList(j, 0) = ComBoTemp
End If
Next j
Next X
hold_name = ComBoList(UBound(ComBoList), 0)
ThisWorkbook.Sheets("Months"). ComboBox1.List = ComBoList
ThisWorkbook.Sheets("Months"). ComboBox1.Value = hold_name
ListDirectory
ListDirectory function
Function ListDirectory(Path As String, AttrInclude As VbFileAttribute, Optional AttrExclude As VbFileAttribute = False) As Collection
Dim Filename As String
Dim Attribs As VbFileAttribute
Set ListDirectory = New Collection
' first call to Dir() initializes the list
Filename = Dir(Path, AttrInclude)
While Filename <> ""
Attribs = GetAttr(Path & Filename)
' to be added, a file must have the right set of attributes
If Attribs And AttrInclude And Not (Attribs And AttrExclude) Then
If Len(Filename) > 4 And InStr(Filename, "Oracle") = 0 Then
ListDirectory.Add Filename, Path & Filename
End If
' fetch next filename
Filename = Dir
Wend
End Function
Am using sorting to sort the folders as all the required folders are named the following. E.g, 201901, 201902, 201903, 201904, 201905 and etc.
I just need a solution for selecting the last 2 folders which are 202003 & 202004.
I could easily delete all the other folders from the path but am looking for a more efficient way to only display 2 of the latest folders in the combo box.
Again, I have already sorted them but once I sorted them I would like to display or select only the latest folders based on sorting them.
K = UBound(ComboList)
TwoNewest = ComboList(K) & vbcrlf & ComboList(K-1)
ComboBox1.List = split(TwoNewest,vbcrlf)
There my be better ways but that'll work
I have a spreadsheet that users can interact with to specify the file path to 4 different files needed to be opened to run some macros. The code includes a check to see if the file path they have entered is valid or not (works excellently). However, what I want to do is have a message box appear if anything doesn't work and then also tell the user which one didn't work.
My code does do that perfectly (albeit in I think a quite convoluted way) however as the array is set to have 4 values it means if the final file isn't present, it starts the text 4 lines down in the message box instead of at the top.
What I want to do, I believe, is ReDim the array to only the amount of files missing so that the MsgBox isn't 3 empty lines below the first sentence. I've kinda figured that bit out but I just could not get it working properly and now I am stumped.
Sub Open_month_0()
On Error GoTo ErrHand
ThisWorkbook.ActiveSheet.Calculate
Dim i As String
Dim j As String
Dim k As String
Dim l As String
Dim m As String
Dim n As String
Dim o As String
Dim p As String
Dim arr(4) As Variant
Dim File_Missing As Integer
'Used as a counter to prompt either an error or successful result
File_Missing = 0
i = Range("LUX_Full_file_path")
j = Range("LUX_Full_file_name")
k = Range("JUP_Full_file_path_M")
l = Range("JUP_Full_file_name_M")
m = Range("JUP_Full_file_path_Q")
n = Range("JUP_Full_file_name_Q")
o = Range("JUP_Full_file_path_A")
p = Range("JUP_Full_file_name_A")
'The if not's check to see if the file path is valid. If it isn't, gets added to array and File_missing begins
If Not Dir(i, vbDirectory) = vbNullString Then
Workbooks.Open (i)
Windows(j).Visible = False
Else
arr(1) = "Lux file"
File_Missing = File_Missing + 1
End If
If Not Dir(k, vbDirectory) = vbNullString Then
Workbooks.Open (k)
Windows(l).Visible = False
Else
arr(2) = "Monthly file"
File_Missing = File_Missing + 1
End If
If Not Dir(m, vbDirectory) = vbNullString Then
Workbooks.Open (m)
Windows(n).Visible = False
Else
arr(3) = "Quarterly file"
File_Missing = File_Missing + 1
End If
If Not Dir(o, vbDirectory) = vbNullString Then
Workbooks.Open (o)
Windows(p).Visible = False
Else
arr(4) = "Annual file"
File_Missing = File_Missing + 1
End If
'Basic error handling procedure that retains function.
If File_Missing > 0 Then
MsgBox ("The following files could not be found. Please check the file paths and try again" & vbCrLf & Join(arr, vbCrLf))
Else
MsgBox "Files opened successfully."
End If
Exit Sub
ErrHand: MsgBox "There has been a critical error with opening the chosen workbooks. If the problem persists, please contact your administrator for assistance."
End Sub
Edit with pictures:
A screenshot of the message box current output
How I'd like the message box to look
Since you just use that array to Join it later you could also just use a String variable MyMissingFiles instead of that array and append the file name.
You even don't need to count the files in File_Missing if this number is not of your interest.
Dim MyMissingFiles As String
If Not Dir(i, vbDirectory) = vbNullString Then
Workbooks.Open (i)
Windows(j).Visible = False
Else
MyMissingFiles = MyMissingFiles & vbCrLf & "Lux file"
End If
' … all the others accordingly here …
If MyMissingFiles <> vbNullString Then
MsgBox ("The following files could not be found. Please check the file paths and try again" & MyMissingFiles)
Else
MsgBox "Files opened successfully."
End If
I have a pull down menu of companies that is populated by a list on another sheet. Three columns, Company, Job #, and Part Number.
When a job is created I need a folder for said company and a sub-folder for said Part Number.
If you go down the path it would look like:
C:\Images\Company Name\Part Number\
If either company name or Part number exists don't create, or overwrite the old one. Just go to next step. So if both folders exist nothing happens, if one or both don't exist create as required.
Another question is there a way to make it so it works on Macs and PCs the same?
Another simple version working on PC:
Sub CreateDir(strPath As String)
Dim elm As Variant
Dim strCheckPath As String
strCheckPath = ""
For Each elm In Split(strPath, "\")
strCheckPath = strCheckPath & elm & "\"
If Len(Dir(strCheckPath, vbDirectory)) = 0 Then MkDir strCheckPath
Next
End Sub
One sub and two functions. The sub builds your path and use the functions to check if the path exists and create if not. If the full path exists already, it will just pass on by.
This will work on PC, but you will have to check what needs to be modified to work on Mac as well.
'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
I found a much better way of doing the same, less code, much more efficient. Note that the """" is to quote the path in case it contains blanks in a folder name. Command line mkdir creates any intermediary folder if necessary to make the whole path exist.
If Dir(YourPath, vbDirectory) = "" Then
Shell ("cmd /c mkdir """ & YourPath & """")
End If
Private Sub CommandButton1_Click()
Dim fso As Object
Dim fldrname As String
Dim fldrpath As String
Set fso = CreateObject("scripting.filesystemobject")
fldrname = Format(Now(), "dd-mm-yyyy")
fldrpath = "C:\Temp\" & fldrname
If Not fso.FolderExists(fldrpath) Then
fso.createfolder (fldrpath)
End If
End Sub
There are some good answers on here, so I will just add some process improvements. A better way of determining if the folder exists (does not use FileSystemObjects, which not all computers are allowed to use):
Function FolderExists(FolderPath As String) As Boolean
FolderExists = True
On Error Resume Next
ChDir FolderPath
If Err <> 0 Then FolderExists = False
On Error GoTo 0
End Function
Likewise,
Function FileExists(FileName As String) As Boolean
If Dir(FileName) <> "" Then FileExists = True Else FileExists = False
EndFunction
Function MkDir(ByVal strDir As String)
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(strDir) Then
' create parent folder if not exist (recursive)
MkDir (fso.GetParentFolderName(strDir))
' doesn't exist, so create the folder
fso.CreateFolder strDir
End If
End Function
This works like a charm in AutoCad VBA and I grabbed it from an excel forum. I don't know why you all make it so complicated?
FREQUENTLY ASKED QUESTIONS
Question: I'm not sure if a particular directory exists already. If it doesn't exist, I'd like to create it using VBA code. How can I do this?
Answer: You can test to see if a directory exists using the VBA code below:
(Quotes below are omitted to avoid confusion of programming code)
If Len(Dir("c:\TOTN\Excel\Examples", vbDirectory)) = 0 Then
MkDir "c:\TOTN\Excel\Examples"
End If
http://www.techonthenet.com/excel/formulas/mkdir.php
For those looking for a cross-platform way that works on both Windows and Mac, the following works:
Sub CreateDir(strPath As String)
Dim elm As Variant
Dim strCheckPath As String
strCheckPath = ""
For Each elm In Split(strPath, Application.PathSeparator)
strCheckPath = strCheckPath & elm & Application.PathSeparator
If (Len(strCheckPath) > 1 And Not FolderExists(strCheckPath)) Then
MkDir strCheckPath
End If
Next
End Sub
Function FolderExists(FolderPath As String) As Boolean
FolderExists = True
On Error Resume Next
ChDir FolderPath
If Err <> 0 Then FolderExists = False
On Error GoTo 0
End Function
Never tried with non Windows systems, but here's the one I have in my library, pretty easy to use. No special library reference required.
Function CreateFolder(ByVal sPath As String) As Boolean
'by Patrick Honorez - www.idevlop.com
'create full sPath at once, if required
'returns False if folder does not exist and could NOT be created, True otherwise
'sample usage: If CreateFolder("C:\toto\test\test") Then debug.print "OK"
'updated 20130422 to handle UNC paths correctly ("\\MyServer\MyShare\MyFolder")
Dim fs As Object
Dim FolderArray
Dim Folder As String, i As Integer, sShare As String
If Right(sPath, 1) = "\" Then sPath = Left(sPath, Len(sPath) - 1)
Set fs = CreateObject("Scripting.FileSystemObject")
'UNC path ? change 3 "\" into 3 "#"
If sPath Like "\\*\*" Then
sPath = Replace(sPath, "\", "#", 1, 3)
End If
'now split
FolderArray = Split(sPath, "\")
'then set back the # into \ in item 0 of array
FolderArray(0) = Replace(FolderArray(0), "#", "\", 1, 3)
On Error GoTo hell
'start from root to end, creating what needs to be
For i = 0 To UBound(FolderArray) Step 1
Folder = Folder & FolderArray(i) & "\"
If Not fs.FolderExists(Folder) Then
fs.CreateFolder (Folder)
End If
Next
CreateFolder = True
hell:
End Function
Here's short sub without error handling that creates subdirectories:
Public Function CreateSubDirs(ByVal vstrPath As String)
Dim marrPath() As String
Dim mint As Integer
marrPath = Split(vstrPath, "\")
vstrPath = marrPath(0) & "\"
For mint = 1 To UBound(marrPath) 'walk down directory tree until not exists
If (Dir(vstrPath, vbDirectory) = "") Then Exit For
vstrPath = vstrPath & marrPath(mint) & "\"
Next mint
MkDir vstrPath
For mint = mint To UBound(marrPath) 'create directories
vstrPath = vstrPath & marrPath(mint) & "\"
MkDir vstrPath
Next mint
End Function
I know this has been answered and there were many good answers already, but for people who come here and look for a solution I could post what I have settled with eventually.
The following code handles both paths to a drive (like "C:\Users...") and to a server address (style: "\Server\Path.."), it takes a path as an argument and automatically strips any file names from it (use "\" at the end if it's already a directory path) and it returns false if for whatever reason the folder could not be created. Oh yes, it also creates sub-sub-sub-directories, if this was requested.
Public Function CreatePathTo(path As String) As Boolean
Dim sect() As String ' path sections
Dim reserve As Integer ' number of path sections that should be left untouched
Dim cPath As String ' temp path
Dim pos As Integer ' position in path
Dim lastDir As Integer ' the last valid path length
Dim i As Integer ' loop var
' unless it all works fine, assume it didn't work:
CreatePathTo = False
' trim any file name and the trailing path separator at the end:
path = Left(path, InStrRev(path, Application.PathSeparator) - 1)
' split the path into directory names
sect = Split(path, "\")
' what kind of path is it?
If (UBound(sect) < 2) Then ' illegal path
Exit Function
ElseIf (InStr(sect(0), ":") = 2) Then
reserve = 0 ' only drive name is reserved
ElseIf (sect(0) = vbNullString) And (sect(1) = vbNullString) Then
reserve = 2 ' server-path - reserve "\\Server\"
Else ' unknown type
Exit Function
End If
' check backwards from where the path is missing:
lastDir = -1
For pos = UBound(sect) To reserve Step -1
' build the path:
cPath = vbNullString
For i = 0 To pos
cPath = cPath & sect(i) & Application.PathSeparator
Next ' i
' check if this path exists:
If (Dir(cPath, vbDirectory) <> vbNullString) Then
lastDir = pos
Exit For
End If
Next ' pos
' create subdirectories from that point onwards:
On Error GoTo Error01
For pos = lastDir + 1 To UBound(sect)
' build the path:
cPath = vbNullString
For i = 0 To pos
cPath = cPath & sect(i) & Application.PathSeparator
Next ' i
' create the directory:
MkDir cPath
Next ' pos
CreatePathTo = True
Exit Function
Error01:
End Function
I hope someone may find this useful. Enjoy! :-)
This is a recursive version that works with letter drives as well as UNC. I used the error catching to implement it but if anyone can do one without, I would be interested to see it. This approach works from the branches to the root so it will be somewhat usable when you don't have permissions in the root and lower parts of the directory tree.
' Reverse create directory path. This will create the directory tree from the top down to the root.
' Useful when working on network drives where you may not have access to the directories close to the root
Sub RevCreateDir(strCheckPath As String)
On Error GoTo goUpOneDir:
If Len(Dir(strCheckPath, vbDirectory)) = 0 And Len(strCheckPath) > 2 Then
MkDir strCheckPath
End If
Exit Sub
' Only go up the tree if error code Path not found (76).
goUpOneDir:
If Err.Number = 76 Then
Call RevCreateDir(Left(strCheckPath, InStrRev(strCheckPath, "\") - 1))
Call RevCreateDir(strCheckPath)
End If
End Sub
Sub FolderCreate()
MkDir "C:\Test"
End Sub
Sub MakeAllPath(ByVal PS$)
Dim PP$
If PS <> "" Then
' chop any end name
PP = Left(PS, InStrRev(PS, "\") - 1)
' if not there so build it
If Dir(PP, vbDirectory) = "" Then
MakeAllPath Left(PP, InStrRev(PS, "\") - 1)
' if not back to drive then build on what is there
If Right(PP, 1) <> ":" Then MkDir PP
End If
End If
End Sub
'Martins loop version above is better than MY recursive version
'so improve to below
Sub MakeAllDir(PathS$)
' format "K:\firstfold\secf\fold3"
If Dir(PathS) = vbNullString Then
' else do not bother
Dim LI&, MYPath$, BuildPath$, PathStrArray$()
PathStrArray = Split(PathS, "\")
BuildPath = PathStrArray(0) & "\" '
If Dir(BuildPath) = vbNullString Then
' trap problem of no drive :\ path given
If vbYes = MsgBox(PathStrArray(0) & "< not there for >" & PathS & " try to append to " & CurDir, vbYesNo) Then
BuildPath = CurDir & "\"
Else
Exit Sub
End If
End If
'
' loop through required folders
'
For LI = 1 To UBound(PathStrArray)
BuildPath = BuildPath & PathStrArray(LI) & "\"
If Dir(BuildPath, vbDirectory) = vbNullString Then MkDir BuildPath
Next LI
End If
' was already there
End Sub
' use like
'MakeAllDir "K:\bil\joan\Johno"
'MakeAllDir "K:\bil\joan\Fredso"
'MakeAllDir "K:\bil\tom\wattom"
'MakeAllDir "K:\bil\herb\watherb"
'MakeAllDir "K:\bil\herb\Jim"
'MakeAllDir "bil\joan\wat" ' default drive