I have a code that is list files in directory. how can I address code to look into parent directory of current workbook directory? i want it to be independent wherever I place it.
(first code addressing to the second one to read file from)
Thanks.
....
Application.ScreenUpdating = False
ShowPDFs "C:\Test\Working\", ws
ws.UsedRange.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
------------------------------
Private Sub ShowPDFs(ByRef fsoPath.......
Just check that the file is not at root level:
....
Application.ScreenUpdating = False
ShowPDFs ThisWorkbook.Path & "\..", ws
ws.UsedRange.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
------------------------------
Private Sub ShowPDFs(ByRef fsoPath.......
The solution you want:
If your behavior is to open an excel window and then open your recent file, please note that you should not forget to add change Drive and then change Directory into your VBA code.
Cause the Excel always start with the default Directory even it's just open your recent file !
Then, these should be help.
Solution A: You don't need to get parent directory to do anything else.
Dim ThisWorkbookPath As String
Dim ThisWorkbookPathParts As Variant
ThisWorkbookPath = ThisWorkbook.Path
ThisWorkbookPathParts = Split(ThisWorkbookPath, _
Application.PathSeparator)
ChDrive ThisWorkbookPathParts(LBound(ThisWorkbookPathParts))
ChDir ThisWorkbookPath
Solution B: You may need to get parent directory to do things else.
Dim ParentPath As String: ParentPath = "\"
Dim ThisWorkbookPath As String
Dim ThisWorkbookPathParts, Part As Variant
Dim Count, Parts As Long
ThisWorkbookPath = ThisWorkbook.Path
ThisWorkbookPathParts = Split(ThisWorkbookPath, _
Application.PathSeparator)
Parts = UBound(ThisWorkbookPathParts)
Count = 0
For Each Part In ThisWorkbookPathParts
If Count > 0 Then
ParentPath = ParentPath & Part & "\"
End If
Count = Count + 1
If Count = Parts Then Exit For
Next
MsgBox "File-Drive = " & ThisWorkbookPathParts _
(LBound(ThisWorkbookPathParts))
MsgBox "Parent-Path = " & ParentPath
Related
I have many macros that have the following path definition:
"X:\Test\3rd Party\Other Files\"
But what I need to, which is what I did with the vbscripts, is make it like this:
"\\ServerName\Folder\Test\3rd Party\Other Files\"
This is because the files that have the macros in them are on the server and they need to be able to be executed by anyone who has access to the server - and since each person might map the drive with a different letter and/or have different levels of access, the first option wont work.
When I use this:
"\\ServerName\Folder\Test\3rd Party\Other Files\"
I get the error:
Sorry, we couldn't find \ServerName\Folder\Test\3rd Party\Other
Files. Is it possible it was moved, renamed or deleted?
When I use this:
"\\ServerName\Folder\Test\3rd Party\Other Files"
Note the backslash missing at the end of the string
I get the error:
Excel cannot access "Other Files". The document may be read-only or
encrypted.
Sub RenameOriginalFilesSheets()
Const TestMode = True
Dim WB As Workbook
Application.ScreenUpdating = False
rootpath = "\\ServerName\Folder\Test\Terminations\"
aFile = Dir(rootpath & "*.xlsx")
Do
Set WB = Application.Workbooks.Open(rootpath & aFile, False, AddToMRU:=False)
WB.Sheets(1).Name = Left$(WB.Name, InStrRev(WB.Name, ".") - 1)
WB.Close True
aFile = Dir()
DoEvents
Loop Until aFile = ""
Application.ScreenUpdating = True
End Sub
Try this, I test in VBA and it works.
Sub serverfolder()
Dim StrFile As String
StrFile = Dir("\\ServerIP\Folder\" & "*")
Do While StrFile <> ""
StrFile = Dir
Loop
End Sub
Hi there I am trying to make a macro that saves a report to a specific folder. Our folders get generated every day like C://Report_Type/2017/11/10 (where /10 is the folder I'd want to save the file to).
The code I have prompts the user to provide the date in order to have the folder located, and then it saves the file according to a specified name.
However when I run the macro it saves the file in the C://Report_Type/2017/11 root folder ignoring the day based on userinput. Could someone help where I got it wrong?
It's a bit complicated to explain, but if you check the code then it makes sense.
Sub PSSaveFile()
Dim myVal2 As Variant
Dim myDate As String
Dim mFilePath As String
myVal2 = InputBox("Please enter today's date in mm\dd format")
myDate = Date - 1
mFilePath = "\\sample\sample_emea\sec_REPORTS\APPS\Reports\Regional\sample_security_app\2017\" & myVal2
ActiveWorkbook.SaveAs FileName:=mFilePath & "SampleLogs-" & myDate & "-12352_checked"
End Sub
Thank you for the help in advance!
Why make it so complicated? I mean why ask for date when you can get that automatically?
Is this what you are trying (UNTESTED)?
Sub PSSaveFile()
Dim FilePath_A As String, FilePath_B As String, FilePath_C As String
Dim sFile As String
FilePath_A = "\\sample\sample_emea\sec_REPORTS\APPS\Reports\Regional\sample_security_app\2017\"
FilePath_B = Format(Date, "mm\dd")
FilePath_C = "\SampleLogs-" & Replace(Date - 1, "/", "-") & "-12352_checked.xlsx"
sFile = FilePath_A & FilePath_B & FilePath_C
ActiveWorkbook.SaveAs sFile, 51
End Sub
Few things
While naming files avoid the use of special characters like \ / : * ? " < > | and hence we use Replace(Date - 1, "/", "-") in the above code
Mention the file extention and file format number
Break your code in easy to understand "parts". makes it easier to understand and manage the code.
Yeah this one is a simpler approach, unfortunately the user who'll be using the macro often checks backlogs so the date she's reviewing isn't always today's or yesterday's date hence the userinput function – Rhyfelwr 14 mins ago
Since you are using InputBox you may want to use this
Sub PSSaveFile()
Dim FilePath_A As String, FilePath_B As String, FilePath_C As String
Dim sFile As String
Dim Ret As Variant
Ret = InputBox("Please enter date in mm\dd format")
If Ret = "" Then Exit Sub
FilePath_A = "\\sample\sample_emea\sec_REPORTS\APPS\Reports\Regional\sample_security_app\2017\"
FilePath_B = Ret
'~~> Check if the folder path exists
If FileFolderExists(FilePath_A & FilePath_B) Then
FilePath_C = "\SampleLogs-" & Replace(Date - 1, "/", "-") & "-12352_checked.xlsx"
sFile = FilePath_A & FilePath_B & FilePath_C
ActiveWorkbook.SaveAs sFile, 51
Else
MsgBox "The folder path " & FilePath_A & FilePath_B & " doesn't exist"
End If
End Sub
Public Function FileFolderExists(strFullPath As String) As Boolean
On Error GoTo Whoa
If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
Whoa:
On Error GoTo 0
End Function
I'm trying to get a macro for Excel 2007to open a folder with a bunch of images in them. Then Create a new workbook and embed the images into it.
Everything works if I comment out the line Sheet.Shapes.AddPicture FileName:=F, linktofile:=msoFalse, savewithdocument:=msoCTrue, Left:=cell.Left + 5, Top:=cell.Top + 5, Width:=560, Height:=310 If I uncomment that line I get "Run-time error '434': Object required"
I've check that Sheet.Shapes is returning a Shapes object, it is but the Shapes object is empty. When I try Sheet.Shapes,AddPicture on a workbook that is opened outside of the macro, it adds the images. I've also checked that Sheet.Shapes.AddShape works with the workbook opened in the macro, it does.
At this point, I'm at a lose for what the issue might be. Does anyone have any experience with this sort of thing? Should I be using a different method? Thanks in advance for any help or guidance.
Sub Macro1()
Dim ImagePath, Flist
ImagePath = GetFolder()
If ImagePath = "" Then Exit Sub
Flist = FileList(ImagePath)
Name = "C:\target.xlsm"
Set Book = Workbooks.Add
Set Sheet = Book.Sheets(1)
For i = 1 To 5
cell = "C" + CStr(i)
F = ImagePath + "\" + Flist(i - 1)
Sheet.Shapes.AddPicture FileName:=F, linktofile:=msoFalse, _
savewithdocument:=msoCTrue, Left:=cell.Left + 5, Top:=cell.Top + 5, Width:=560, Height:=310
Next
Book.SaveAs FileName:=Name, FileFormat:=52
Book.Close
End Sub
Function FileList(ByVal fldr As String) As Variant
'Lists all the files in the current directory
'Found at http://www.ozgrid.com/forum/showthread.php?t=71409
Dim sTemp As String, sHldr As String
If Right$(fldr, 1) <> "\" Then fldr = fldr & "\"
sTemp = Dir(fldr & "*.png")
If sTemp = "" Then
FileList = False
Exit Function
End If
Do
sHldr = Dir
If sHldr = "" Then Exit Do
sTemp = sTemp & "|" & sHldr
Loop
FileList = Split(sTemp, "|")
End Function
Function GetFolder() As String
Folder:
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "New Screenshot Folder"
.Show
num = .SelectedItems.Count
If .SelectedItems.Count = 0 Then
GetFolder = ""
Else: GetFolder = .SelectedItems(1)
End If
End With
End Function
You can't define a cell by creating the string "C1", that's just the address. The way you did it, cell is a string and a string doesn't have any properties. What you want is a range object so either use
Dim cell As Range
Set cell = sheet.Range("C" & i)
or
Dim cell As Range
Set cell = sheet.Cells(i, 3)
You should always Dim all variables, use Option Explicit on top of your module so you don't forget it ;)
This will often prevent mistakes. Of course you should Dim them with the correct type, i.e. Dim FilePath As String.
The correct command would be:
Sheet.Shapes.AddPicture Filename:=F, linktofile:=msoFalse, _
savewithdocument:=msoCTrue, Left:=Range(cell).Left + 5, Top:=Range(cell).Top + 5, Width:=560, Height:=310
I strongly advise you to change your Name variable name, as it will cause errors on recent versions of excel.
I am trying to look in a folder to pull the latest workbook by date, open the workbook up as my src data, copy the selected worksheet and data from src and then paste to my master workbook. Finally closing the src workbook without saving any change. I'm having issues on where I should place my file paths and filenames.
Function NewestFileName(ByVal path As String, ByVal FileTemplate As String) As String
Dim FileDateCrnt As Date
Dim FileDateNewest As Date
Dim FileNameCrnt As String
Dim FileNameNewest As String
If Right("G:\AOC\GROUPS1\SAC\TEST", 1) <> "\" Then
path = "G:\AOC\GROUPS1\SAC\TEST" & "\"
End If
FileNameCrnt = Dir$("G:\AOC\GROUPS1\SAC\TEST" & Book1.xlsx)
If FileNameCrnt = "Book1.xlsx" Then
NewestFileName = "Book2.xlsx"
Exit Function
End If
FileNameNewest = FileNameCrnt
FileDateNewest = FileDateTime("G:\AOC\GROUPS1\SAC\TEST" & FileNameCrnt)
Do While True
FileNameCrnt = Dir$
If FileNameCrnt = "" Then Exit Do
FileDateCrnt = FileDateTime(path & FileNameCrnt)
If FileDateCrnt > FileDateNewest Then
FileNameNewest = FileNameCrnt
FileDateNewest = FileDateCrnt
End If
Loop
NewestFileName = FileNameNewest
Call ReadDataFromCloseFile
End Function
Sub ReadDataFromCloseFile()
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Dim src As Workbook
Set src = Workbook.Open("G:\AOC\GROUPS1\SAC\TEST.xlsx", True, True)
Dim iTotalRows As Integer
iTotalRows = src.Worksheets("sheet1").Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row)
Dim iCnt As Integer
For iCnt = 1 To iTotalRows
Worksheets("sheet1").Range("B" & iCnt).Formula = src.Worksheets("sheet1").Range("B" & iCnt).Formula
Next iCnt
src.Close False
Set scr = Nothing
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
First things first:
If you have a question or encounter an error, then spell it out. It's hard to find out where your error is, without knowing on which line it occurs.
Your function in a whole doesn't make that much sense. For taking a good look at it, commenting would've been very helpful.
Let's go through your code step by step:
If Right("G:\AOC\GROUPS1\SAC\TEST", 1) <> "\" Then
path = "G:\AOC\GROUPS1\SAC\TEST" & "\"
End If
This if-condition will always trigger, because the String you put in there, is always the same and it'll always miss the "\".
So if your path doesn't change then you can change that to path = "G:\AOC\GROUPS1\SAC\TEST\"
FileNameCrnt = Dir$("G:\AOC\GROUPS1\SAC\TEST" & Book1.xlsx)
If FileNameCrnt = "Book1.xlsx" Then
NewestFileName = "Book2.xlsx"
Exit Function
End If
I'm not sure what you are trying to do here. You are setting FileNameCrnt to a string in the first line (you are missing the "\" btw). I guess "Book1.xlsx" is the real name of your workbook, so your String should look either like this: "G:\AOC\GROUPS1\SAC\TEST\Book1.xlsx" or you could do something like this
fileName = "Book1.xlsx"
FileNameCrnt = Dir$("G:\AOC\GROUPS1\SAC\TEST" & fileName )
Next: You would(!) always exit the function there, if the line above would work. You set FilenameCrnt to Book1.xlsx, then check it via an if-clause, the check will always return true, afterwards you'd always exit.
I get the idea of your loop, but it too is broken. Start by changing this: If FileNameCrnt = "" Then Exit Do to something else. Your variable will never be empty so your loop will always cause a runtime error. Start changing the first parts of your function and get to that later. I think you will have a better idea how all this should work. And it's always better to try solving some things by yourself. ;)
EDIT:
It's always helpful to make a flow chart on how your program should run.
Something like:
Get my current filename
Get date of my current file
Check if there is a newer file (a file with a higher date than my old
date)
Get dates of all files (loop through all files)
GET highest date
Compare highest date to date of my current file
if there is a file with a higher date, update current filename to filename with higher date
HTH
I am a new to VBA. My issue is that I have a file that will be updated it into a specific folder by different users. Now everytime a user updates the file, the name of the file might not be the samefolder. However, I can narrow it down using specific keywords. I have been able to search for a file using a keyword but not multiple keywords. Please can you point me in the right direction on how I can use multiple keywords to find a file in a folder? Is it possible to write code that will work like the below?
Sub Start_countries()
Dim keyword, pathname, filename As String
pathname = "C:\XYZ\"
keyword = "lol" Or "rofl" Or "lmfao" Or "rotfl"
filename = Dir(pathname & "*.xls*")
Do While filename <> "*.xls*"
If LCase(filename) Like "*" & keyword & "*" Then
Set wb = Workbooks.Open(pathname & filename)
Find_count_sum_in_file filename
wb.Close SaveChanges:=True
Else
msgbox = "No file Found"
End If
Loop
End Sub
Try the following (adapted following your comment):
Private Const MAX_KWD = 5 ' use a constant to make sure everyone uses the same value
Sub Start_countries()
Dim keyword(1 To MAX_KWD), pathname As String
'Keywords for first file search
keyword(1) = "lol"
keyword(2) = "rofl"
keyword(3) = "lmfao"
keyword(4) = "rotfl"
pathname = "C:\XYZ1\"
search_for_files keyword(), pathname
'Keywords for second file search
keyword(1) = "omg"
keyword(2) = "fyi"
keyword(3) = "ok"
keyword(4) = "brb"
pathname = "C:\XYZ2\"
search_for_files keyword(), pathname
End Sub
Sub search_for_files(keyword(), pathname)
Dim filename As String, s As String
Dim i As Integer
filename = Dir(pathname & "*.xls*")
Do While InStr(filename, ".xls") <> 0
s = LCase(filename)
For i = 1 To MAX_KWD
If (InStr(s, keyword(i)) > 0) Then Exit For ' found!
Next i
If (i <= MAX_KWD) Then
Set WB = Workbooks.Open(pathname & filename)
Find_count_sum_in_file filename
WB.Close SaveChanges:=True
Else
MsgBox "No file Found"
End If
filename = Dir()
Loop
End Sub
Note that in Dim pathname, filename, s As String only s is declared as String; all others are declared as Variant (the As String does not apply to all variables declared on the line).
Note also that in your While filename <> "*.xls*" the test will be exact, i.e. it will look also for asterisks (*) in filename.