Is there a way to Get Last Directory so I can Save As into? - vba

I am able to create a new directory on my desktop, my issues is that I don't know how to save multiple files into that folder, within the same Sub, since it has a dynamic name.
Option Explicit
Sub Make_Folder_On_Desktop()
Dim selectionsheet As Worksheet
Dim Group As Variant
Dim amount As Long
Dim BU As Long
Dim BUname As Variant
Dim sFilename As Variant
Set selectionsheet = Sheets("Project Selection")
Group = selectionsheet.Range("A19").Value
amount = selectionsheet.Range("B19").Value
BU = selectionsheet.Range("B6").Value
BUname = selectionsheet.Range("C6").Value
sFilename = BU & " - " & BUname
MkDir Group & " - " & amount & " - " & Format(Date, "mm-dd-yyyy") & " - "
& Format(Time, "hhmmss")
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & sFilename
End Sub
Last line is where I'm having the issue. I have "ThisWorkbook.Path" but can't figure out how to get it into the new folder I just created.

MkDir Group & " - " & amount & " - " & Format(Date, "mm-dd-yyyy") & " - " & Format(Time, "hhmmss")
It's hard to know what the folder name is that you just created, because that instruction is responsible for too many things. Split it up.
Build/concatenate a folder name
Make a directory by that name
If we split up the work, things get much simpler:
Dim path As String
path = Group & " - " & amount & " - " & Format(Date, "mm-dd-yyyy") & " - " & Format(Time, "hhmmss")
MkDir path
And now we have the path in the ...path variable, readily usable for anything you might want to do with it:
ActiveWorkbook.SaveAs path & "\" & sFilename
As a side note, if you make the date format yyyy-mm-dd instead, you're ISO-compliant (i.e. the date is unambiguous everywhere in the world), and the folders become sortable by name.
Note that the procedure's name is misleading: it doesn't care where the folder is, and there's nothing that says it's under %USERPROFILE%\Desktop. Use Environ$("USERPROFILE") to retrieve the base path for the current user's profile directory.

Related

Ms Access Get filename with wildcards or loop

I am using MS Access Forms and I am trying to open a file but don't know how to open the file based knowing only part of the name. Example below works
Private Sub Open_Email_Click()
On Error GoTo Err_cmdExplore_Click
Dim x As Long
Dim strFileName As String
strFileName = "C:\data\office\policy num\20180926 S Sales 112.32.msg"
strApp = """C:\Program Files\Microsoft Office\Office15\Outlook.exe"""
If InStr(strFileName, " ") > 0 Then strFileName = """" & strFileName & """"
x = Shell(strApp & " /f " & strFileName)
Exit_cmdExplore_Click:
Exit Sub
Err_cmdExplore_Click:
MsgBox Err.Description
Resume Exit_cmdExplore_Click
End Sub
If I change the strFilename to being
strFileName = "C:\data\" & Me.Office & "\" & Me.nm & " " & Me.pol & "\" & "*"& " S Sales " & Me.amt & "*" & ".msg"
It includes the * rather than using it as a wildcard, the date/numbers can be anything or in another format but always eight numbers. I tried using a while loop on the numbers but I am not sure the best way of doing this sorry.
You can use the Dir function to iterate over all files that match a string pattern.
strApp = """C:\Program Files\Microsoft Office\Office15\Outlook.exe"""
Dim strFilePattern As String
strFilePattern ="C:\data\" & Me.Office & "\" & Me.nm & " " & Me.pol & "\" & "*"& " S Sales " & Me.amt & "*" & ".msg"
Dim strFileName As String
strFileName = Dir(strFilePattern)
Do While Not strFileName = vbNullString
If InStr(strFileName, " ") > 0 Then strFileName = """" & strFileName & """"
x = Shell(strApp & " /f " & strFileName)
strFileName = Dir
Loop
The first call to Dir with the pattern as a parameter will find the first file that matches the pattern supplied. All subsequent calls without the pattern will return the next file that matches the pattern.
So, lets rebuild the question a bit. Imagine that you are having the following 5 files in a given folder:
A:\peter.msg
A:\bstack.msg
A:\coverflow.msg
A:\heter.msg
A:\beter.msg
and you need to find the files, that correspond to "A:\*eter.msg" and print them.
For this, you need to use the keyword Like:
Sub TestMe()
Dim someNames As Variant
someNames = Array("A:\peter.msg", "A:\bstack.msg", _
"A:\coverflow.msg", "A:\heter.msg", "A:\beter.msg")
Dim cnt As Long
For cnt = LBound(someNames) To UBound(someNames)
If someNames(cnt) Like "A:\*eter.msg" Then
Debug.Print someNames(cnt)
End If
Next
End Sub
Loop through files in a folder using VBA?

File is not saving to newly made folder in VBA

I have a macro that created a folder by data within a pathway, and I want a cut of a manager roster to be saved in that folder. Since the folder name varies, this needs to be dynamic.
I want it to go something like this:
Dim sPath As String
sPath = "M:\mgr1_TCR_Reports\"
If Len(Dir(sPath & "_" & Format(Date, "mm_dd_yyyy"), vbDirectory)) = 0 Then
MkDir (sPath & "_" & Format(Date, "mm_dd_yyyy"))
End If
End Sub
and saving this like:
.SaveAs Filename:="M:\mgr1_TCR_Reports\" & "_" & Format(Date, "mm_dd_yyyy_") & "\" & Manager, FileFormat:=xlOpenXMLWorkbook, Password:=""
.Close
But I keep getting a runtime 1004: document not saved on ^^^ the second line of code I provided.
Any idea what's going on?

Creating a macro that resets file and saves as new day

At work, I've been trying to create a macro that will automatically clear a certain range - only content -, the range being B78:G83.
After clearing this range, I'd like the macro to save the current file under a new name. The new name should be the current day, with format "dd mmmm" (two digits for the name, a space in between and then the full month's name)
The file path is (f.e.)
"T:\RESERVATIONS\Duty Report\2017\4. April\25 april"
with the year, month and current date being variable (as we make separate folders for these files at work).
Sub NieuweDag()
'
' NieuweDag Macro
' Invoer wissen en opslaan als nieuwe dag
'
' Sneltoets: Ctrl+q
'
Range("B78:G83").Select
Range("G82").Activate
Selection.ClearContents
Dim FilePath As String
Dim NewName As String
FilePath = "T:\RESERVATIONS\Duty Report\": NewName = FilePath & Year(Now()) & "\" & Month(Now()) & ". " & MonthName(Now()) & "\" & Format(Date, "dd mmmm") & ".xlsm"
ActiveWorkbook.SaveAs Filename:=NewName, FileFormat _
:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End Sub
This is what I've got but it doesn't work. I get Error 5. It's in dutch, so allow me to translate:
Error 5 during launch:
Invalid procedure-call or invalid argument
Anyone out here be able to help me out?
The proper format is MonthName(number of month, [abbreviate]), you should use
MonthName(Month(Now()))
instead of
MonthName(Now())
Plus, you can enhance your code by using
Range("B78:G83").ClearContents
instead of
Range("B78:G83").Select
Range("G82").Activate
Selection.ClearContents
You can reduce the amount of coding required to create NewName by changing
NewName = FilePath & Year(Now()) & "\" & Month(Now()) & ". " & MonthName(Now()) & "\" & Format(Date, "dd mmmm") & ".xlsm"
to
NewName = FilePath & Format(Now(), "yyyy\\m. mmmm\\dd mmmm") & ".xlsm"

How to delete a folder? In VB.Net

'' I created a folder like this and it contains many databases. When I'm about to submit again the button there was an error of "Database already exist" i am saying that I'm about to delete the src folder instead of the databases. What should I do then? What code to use?
Dim testPath1 As String = Form1.Dir_folder.Text & "\DDC OS" & "\CARD DECK" & "\" & DateTime.Now.ToString("yyyyMMdd") & "\" & batchFolderName & "\Compare"
Dim testPath5 As String = Form1.Dir_folder.Text & "\DDC OS" & "\CARD DECK" & "\" & DateTime.Now.ToString("yyyyMMdd") & "\" & batchFolderName & "\Entry1"
Dim testPath2 As String = Form1.Dir_folder.Text & "\DDC OS" & "\CARD DECK" & "\" & DateTime.Now.ToString("yyyyMMdd") & "\" & batchFolderName & "\Entry2"
Dim testPath3 As String = Form1.Dir_folder.Text & "\DDC OS" & "\CARD DECK" & "\" & DateTime.Now.ToString("yyyyMMdd") & "\" & batchFolderName & "\Images"
Dim testPath4 As String = Form1.Dir_folder.Text & "\CBATCH"
Dim testPath6 As String = Form1.Dir_folder.Text & "\CBATCH" & "\CardDeck" & "\" & DateTime.Now.ToString("yyyyMMdd")
If Not IO.Directory.Exists(testPath5) Then
MkDir(testPath5)
End If
If Not IO.Directory.Exists(testPath1) Then
MkDir(testPath1)
End If
If Not IO.Directory.Exists(testPath2) Then
MkDir(testPath2)
End If
If Not IO.Directory.Exists(testPath3) Then
MkDir(testPath3)
End If
If Not IO.Directory.Exists(testPath4) Then
MkDir(testPath4)
End If
If Not IO.Directory.Exists(testPath6) Then
MkDir(testPath6)
End If
To be honest MkDir isnt the quickest way to create directories, but for consistency, just use
RmDir(testPath1)
A better performing way would be to use..
My.Computer.FileSystem.CreateDirectory(testPath1)
to create a directory and ..
My.Computer.FileSystem.DeleteDirectory(testPath1,FileIO.DeleteDirectoryOption.DeleteAllContents)
to delete it/
You can't. My answer had nothing to do with using databases. Which is why I apologised for misreading your original question. I should delete it and let someone else answer.

Move file into dynamically created folder with VB Script

I am working on a backup script in VBS that creates a folder and then copies a powerpoint file into the most recently created folder.
Everything works great except MoveFile command at the bottom
Here is what I got so far (the bottom code is most important but just so everyone can understand where I am coming from):
sourceDir = "T:\Team"
destinationDir = "T:\Team\Archive\Archive"
const OverwriteExisting = True
intNum = 1
strDirectory = destinationDir & "_" & replace(date,"/",".") & "_" & intNum
'This checks if the folder exists and if not it will create a folder with the date and increment the folder name incase there are multiple updates in a single day.
if not filesys.FolderExists(destinationDir) then
While filesys.FolderExists(destinationDir & "_" & replace(date,"/",".") & "_" & intNum) = True
intNum = intNum + 1
Wend
Set archivefolder = filesys.CreateFolder(destinationDir & "_" & replace(date,"/",".") & "_" & intNum)
Else
Set archivefolder = filesys.CreateFolder(destinationDir)
Set objFolder = fso.CreateFolder(strDirectory)
End if
Dim thisday, thisdayy, thisdayyy
Today_Date()
' This is the problem code
filesys.MoveFile "T:\Arriva\Project_Organigram_" & thisday & "." & thisdayy & "." & thisdayyy & ".pptm", "destinationDir & "\" & Project_Organigram_" & thisday & "." & thisdayy & "." & thisdayyy & ".pptm"
Function Today_Date()
thisday=Right(Day(Date),2)
thisdayy=Right("0" & Month(Date),2)
thisdayyy=Right("0" & Year(Date),2)
End Function
This results in a folder being created as "T:\Team\Archive\Archive_03.12.2014_1
My goal is to be able to move the file in T:\Team to the dynamically created folder above.
Everything works great until the MoveFile part. The destination is the part throwing a "type mismatch" at the line where I define the strDirectory
I am just learning this type of programming so please let me know if I can provide any further details!
Thank you in advance!
You have a couple syntax errors with your quotes that are cancelling each other out. Change your line to this:
filesys.MoveFile "T:\Team\Project_Organigram_" & thisday & "." & thisdayy & "." & thisdayyy & ".pptm", "destinationDir" & "_" & replace(date,"/",".") & "_" & intNum & "\" & "Project_Organigram_" & thisday & "." & thisdayy & "." & thisdayyy & ".pptm"