Forgive me if this is an easy problem, Im still learning..
I have an excel file, that takes data and performs analytics to compose graphs. right now method to update is manual copying and pasting from 2 other data sources. I can easily create a macro to import the first source as the data location/file name is always the same. The second source is trickier, as the file has some standardized naming convention, but a date is added, as it is refreshed once a week, every Monday or tuesday. is there a way to automate pulling the data from the external source (sharepoint library) and telling it to find the most current version? either by understanding the date convention added in the file name, or by another means of modified date or other criteria? the file is kept with previous archived copies. I do not own the report, sharepoint site, or library it is kept in, so I cant influence those factors :(. any help appreciated, and I can provide better details and explanation.
There are two basic approaches that I know of, either allow the user to choose the file through a dialog box, or use the "Dir" function to find the file with the most recent date.
First approach (code I use frequently):
Public Function ChooseOpenFile() As String
Dim strSlash As String
If InStr(1, ActiveWorkbook.Path, "/") > 0 Then
strSlash = "/"
Else
strSlash = "\"
End If
With Application.FileDialog(msoFileDialogOpen)
.Title = "Select the first file to open in series:"
.InitialFileName = Replace(ActiveWorkbook.Path, "http:", "", 1) & strSlash
Call .Filters.Clear
Call .Filters.Add("Excel Files Only", "*.xls, *.xlsx, *.xlsb")
'only allow the user to select one file
.AllowMultiSelect = False
'make the file dialog visible to the user
intChoice = .Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
ChooseOpenFile = .SelectedItems(1)
End If
End With
End Function
As for the second approach, as long as you can already access the folder programmatically, you build a loop to cycle through the files, extract the date from each file, test for being more recent than previous versions and store the filename of the most recent version to pass out of the loop.
Function MostRecentFile() As String
Dim dateTest As Date
Dim dateRecent As Date
Dim strMyFile As String
Dim strMyFolder As String
Dim strCurrentFile As String
Dim strSlash As String
strMyFolder = ThisWorkbook.Path
If InStr(1, strMyFolder, "/") > 0 Then
strSlash = "/"
Else
strSlash = "\"
End If
strMyFile = Dir(Replace(strMyFolder, "http:", "") & strSlash & "*.xls*")
Do While strMyFile <> ""
'Modify this line (number of characters and extension to replace) as needed.
dateTest = CDate(Replace(Right(strMyFile, 15), ".xls*", ""))
If dateTest > dateRecent Then
dateRecent = dateTest
strCurrentFile = strMyFile
End If
Stop
Dir
Loop
MostRecentFile = strCurrentFile
End Function
You can browse to the file.
Sub GetOpenFile()
Dim fileStr As String
fileStr = Application.GetOpenFilename()
If fileStr = "False" Then Exit Sub
Workbooks.Open fileStr
End Sub
If you want some kind of automated solution, based on your system date, like the next Monday ot Tuesday, you can get the machine to figure it out, and pass the result to the appropriate string in the file path.
Sub NameAsNextMon()
Dim K As Integer
Dim dteMon As Date
Dim tempName As Variant
K = Weekday(Now)
dteMon = Now() + (9 - K)
tempName = Year(dteMon) & "-" & Month(dteMon) & "-" & Day(dteMon) & ".xls"
Do
fName = Application.GetSaveAsFilename(tempName)
Loop Until fName <> False
ActiveWorkbook.SaveAs Filename:=fName
End Sub
Related
I'm trying to adapt an Excel form I created that uses drive locations to save copies of the form, to work with SharePoint in a similar manner. Currently, the first macro is set up such that it will search the contents of a particular folder to determine the next available number in the queue (i.e. if 1, 2 and 4 already exist, it will assign 3) and save the sheet as that next available number. When the sheet is complete, the second macro will save the file with a specified name based on data within the sheet, in another specified location (again based on data defined within the sheet). The drive is in the process of being retired in our company and everything moved to Cloud-based storage, so I would like a way to complete the same actions but using SharePoint directories.
The code for the first macro is as follows:
Dim strDir As String
Dim file As Variant
Dim savename As Integer
Dim savename_string As String
strDir = "R:\Queue\"
savename = 1
savename_string = CStr(savename)
file = Dir(strDir)
While (CInt(savename_string) = savename)
If file <> (savename & ".xlsm") Then
If file = "" Then
savename = savename + 1
Else
file = Dir
End If
ElseIf file = (savename & ".xlsm") Then
savename = savename + 1
savename_string = CStr(savename)
file = Dir(strDir)
End If
Wend
ActiveWorkbook.SaveAs ("R:\Queue\" & savename_string & ".xlsm")
And then the code for the second macro is as follows:
Dim answer As Integer
Dim error As Integer
Dim delete As String
answer = MsgBox("Are you sure you want to save sheet & close?", vbYesNo + vbQuestion, "WARNING")
If answer = vbYes Then
'Define PWO, assembly, terminal, strand, and gauge As Strings, and define which cells they are on the sheet
delete = ActiveWorkbook.Name
ActiveWorkbook.SaveAs ("R:\" & terminal & assembly & Space(1) & gauge & strand & Space(1) & PWO & Space(1) & Format(Now(), "MM-DD-YYYY") & ".xlsm")
Kill ("R:\Queue\" & delete)
ActiveWorkbook.Close
Else
Exit Sub
End If
Currently the second macro works correctly when replacing the locations with the SharePoint URL locations, but when doing the same with the first macro, it returns an error message "Bad file name or number" at the line file = Dir(strDir). Can I get this code in working order, or is there a better way I should go about this? Thanks!
I have three workbooks (Book1,Book2,Book3) all saved as xlsx files. Each day, these workbooks are updated. Assume all workbooks belong to the following directory: C:\Users\abc\Documents\Example which also contains many other files (d,e,f.... etc). I need to check that Book1,Book2,Book3 are updated so that 'Date Modified' = Today's date. If date modified does not equal today's date i need the code to stop running and warn "Incorrect Date". I imagine this task will involve running a for-loop but I am quite new to VBA.
Try:
Sub test()
Dim arrFileNames As Variant
Dim i As Long
Dim strPath As String
Dim strExt As String
arrFileNames = Split("Book1,Book2,Book3", ",")
strPath = "C:\Users\marios.p\Desktop\test" & "\"
strExt = ".xlsx"
Set fs = CreateObject("Scripting.FileSystemObject")
For i = LBound(arrFileNames) To UBound(arrFileNames)
Set f = fs.GetFile(strPath & arrFileNames(i) & strExt)
If f.DateLastModified < Date Then
MsgBox "Incorrect Date"
End If
Next i
End Sub
Suppose, we have one folder with only one macro file and every day we are saving excel file in the same folder received via mail. However, filename every day will get changed. I mean to say what ever file we are getting through mail do not have a standard name. Now, we have two files in the same folder.
Can we open another file which we have saved with some random name available in the same folder using a macro? Here, the name of another file is not standard. Additionally, after running a macro, we also want to delete that file.
You can get the filename of the newest file within a directory by this:
Option Explicit
Private Sub GetNewestFilename()
Dim searchDirectory As String
Dim searchPattern As String
Dim currentFilename As String
Dim NewestFilename As String
Dim NewestFiledate As Date
searchDirectory = Application.DefaultFilePath & "\"
searchPattern = "*.xl*"
currentFilename = Dir(searchDirectory & searchPattern, 0)
If currentFilename <> "" Then
NewestFilename = currentFilename
NewestFiledate = FileDateTime(searchDirectory & currentFilename)
Do While currentFilename <> ""
If FileDateTime(searchDirectory & currentFilename) > NewestFiledate Then
NewestFilename = currentFilename
NewestFiledate = FileDateTime(searchDirectory & currentFilename)
End If
currentFilename = Dir
Loop
End If
MsgBox NewestFilename
Dim wb As Workbook
Set wb = Workbooks.Open(searchDirectory & NewestFilename)
' do something
wb.Close SaveChanges:=False
Set wb = Nothing
' Kill searchDirectory & NewestFilename ' Delete the file
End Sub
I'm trying to save excel file into a specific path.
So basically, when I click the button, I'm creating a folder, and want to save the file inside that folder.
The created folder has the current month as name. I'm trying to save into that current month folder.
'Create folder as Month Name. Save filename as date inside "month".
Dim sDate As String = DateTime.Now.ToString("yyyy-MM-dd") & "_" & DateTime.Now.ToString("HH-mm-ss")
Dim sMonth As String = DateTime.Now.ToString("MMMM")
Dim sFolder = Application.StartupPath & "\Resources\Excel\"
My.Computer.FileSystem.CreateDirectory(sFolder & Format(sMonth))
Dim sfinal = Path.Combine(sFolder, sMonth)
xlSh.SaveAs(sfinal & Format(sDate) & ".xlsx")
xlApp.Workbooks.Close()
xlApp.Quit()
As it is, this code doesn't give me any errors. But instead of creating a folder named "March" <-current month and saving inside it, it saves the file in \Excel\ and it also creates folder in the same place.
you could use the following function (similar to .NET System.IO.Path.Combine)
Function PathCombine(path1 As String, path2 As String)
Dim combined As String
combined = path1
If Right$(path1, 1) <> Application.PathSeparator Then
combined = combined & Application.PathSeparator
End If
combined = combined & path2
PathCombine = combined
End Function
Hope this helps!
After long hours of excruciating pain, I've finally did it!
Apparently I was missing an "\"
Since "sMonth" became dynamic name, which later I wanted to use as path, and save files in that folder. I needed to simply put that "\" after sMonth, to tell it to save inside it.
Before I realize this... I've broken down, simplified the code as much as I could so I can logically connect the pieces. What I ended up with, is something slightly different. Now the SaveAS properly saves the file inside the new folder.
Dim sDate As String
sDate = DateTime.Now.ToString("yyyy-MM-dd") & "_" & DateTime.Now.ToString("HH-mm-ss")
Dim sMonth As String
sMonth = DateTime.Now.ToString("MMMM")
Dim sFileName As String
sFileName = sDate + ".xlsx"
Dim sFolder As String
sFolder = Application.StartupPath & "\Resources\Excel\"
Dim sfinal As String
sfinal = (sFolder & sMonth & "\") '<- this thingie here o.O
My.Computer.FileSystem.CreateDirectory(sFolder & Format(sMonth))
xlSh.SaveAs(sfinal & Format(sFileName))
xlApp.Workbooks.Close()
xlApp.Quit()
Thanks for the help.
You don't appear to actually be setting the save path to the created directory. Instead, I believe you're appending the month to the beginning of the file name in the xlSh.SaveAs(sFinal & Format(sDate) & ".xlsx"). Basically (though I'm not sure of the specific command) you need to navigate to the folder you created after you create it. Probably something to the format of
My.Computer.FileSystem.ChangeDirectory(sFolder & Format(sMonth))
though I don't know that that specific command actually exists as I wrote it.
To those who have been wondering wtf I was doing with all this, here is the full sub. And if anyone needs something similar. Thanks for the support. Problem has been resolved.
Private Sub Button_Click(sender As Object, e As EventArgs) Handles Button.Click
Dim xlApp As Excel.Application
Dim xlSh As Excel.Worksheet
xlApp = New Excel.Application
xlApp.Workbooks.Add()
xlSh = xlApp.Workbooks(1).Worksheets(1)
'Items from listbox1 to be exported into excel, second row, second column.
Dim row As Integer = 2
Dim col As Integer = 2
For i As Integer = 0 To ListBox1.Items.Count - 1
xlSh.Cells(row, col) = ListBox1.Items(i)
row = row + 1
Next
row += 1
col = 1
'Items from listbox2 to be exported into excel, second row, third column.
Dim row2 As Integer = 2
Dim col2 As Integer = 3
For i As Integer = 0 To ListBox2.Items.Count - 1
xlSh.Cells(row2, col2) = ListBox2.Items(i)
row2 = row2 + 1
Next
row2 += 1
col2 = 1
'Create folder as Month Name. Save filename as date inside that folder.
'Make filename be yyyy-MM-DD_HH-mm-ss
Dim sDate As String
sDate = DateTime.Now.ToString("yyyy-MM-dd") & "_" & DateTime.Now.ToString("HH-mm-ss")
'This will be used as name for the new folder.
Dim sMonth As String
sMonth = DateTime.Now.ToString("MMMM")
'Filename + extension.
Dim sFileName As String
sFileName = sDate + ".xlsx"
'This is the path.
Dim sFolder As String
sFolder = Application.StartupPath & "\Resources\Excel\"
'This is the path combined with sMonth to make the final path.
Dim sfinal As String
sfinal = (sFolder & sMonth & "\")
'Check if folder with the name sMonth already exists.
If Dir(sFolder, vbDirectory) = sMonth Then
'If it exist, then simply save the file inside the folder.
xlSh.SaveAs(sfinal & Format(sFileName))
Else
'If it doesn't exist:
'This is the creation of sMonth folder, inside "\excel\.
My.Computer.FileSystem.CreateDirectory(sFolder & Format(sMonth))
'This saves the excel file at path sfinal, with filename of sFileName
xlSh.SaveAs(sfinal & Format(sFileName))
End If
'Close everything.
xlApp.Workbooks.Close()
xlApp.Quit()
End Sub
I find this method to be much easier.
Create a FileSystemObject and use BuildPath Method, like so:
Set fs = CreateObject("Scripting.FileSystemObject")
skPath = fs.BuildPath(ActiveDocument.Path, "Survival Story of Sword King")
Attention: ActiveDocument.Path is current directory in Word and does not work in excel or other. for excel it would be ActiveWorkbook.Path
My point is some methods or namespace are application specific.
I'm trying to have the program to copy the files with certain characters. The files to be copied over should be between the today's date and 100 days before today. My program can run, but nothing show up on the new folder. I did make sure that the file is between those date. I don't get any error, so I have no idea where to fix. I have tried other methods, none of them working.
I try to mix the code from http://www.rondebruin.nl/win/s3/win026.htm. I was playing abround with it, only copy_folder() is working. I'm getting runtime error '53' - File not found on Copy_Certain_Files_In_Folder() and Copy_Files_Dates() give me nothing as well.
Anyway, what is wrong with my code and how can I incorporate the FileExt to my code below? Thanks!
Sub CopyPasteFiles()
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim Fdate As Date
Dim FileExt As String
Dim objFile As Object
Dim objFolder As Object
FromPath = "C:\Users\Run" '<< Change
ToPath = "C:\Users\Test" '<< Change
FileExt = "*BT.csv"
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If
If FSO.FolderExists(ToPath) = False Then
MsgBox ToPath & " doesn't exist"
Exit Sub
End If
For Each objFolder In FSO.GetFolder(FromPath).SubFolders
For Each objFile In objFolder.Files
Fdate = Int(objFile.DateCreated)
If Fdate >= Date And Fdate <= Format(DateAdd("d", -100, Date), "dd mmmm yyyy") Then
objFile.Copy ToPath
End If
Next objFile
Next objFolder
MsgBox "You can find the files from " & FromPath & " in " & ToPath
End Sub
Okay, I tried to add some comments to give you some direction.
The first problem you had, is you weren't doing anything with the root folder - you were trying to go right into the subfolders, which is probably why you said it "highlighted" the lines on the outer loop layer. (The highlighted line is the line that will be executed when you hit F8 next.)
What I did was break the copy action into another procedure so you can call it recursively on any subfolders. It's just one way to do it - there are other, probably simpler ways, but it's what came to mind for me as I'm kind of used to digging in folders and recordsets recursively this way.
Another problem you had was your method of comparing dates. The format of the .DateCreated property comes in with date and time. You can directly compare this to the Now() function, which returns date and time - but if you try to compare to the Date() function it won't work because it's a different format.
I wasn't sure what you were trying to do with the file extension bit. I assumed you wanted to use it as a filter, so that's what I did with it.
A few notes:
You currently are telling the user at the end that "you can find the files from " but you are not checking if that is true. You may want to add a check after the .Copy action and then add your results to an array or something so you can show the user a list of files that successfully copied and files that did not. When I was testing, I created the folders you had in my Users directory, and I got an error when trying to copy of not having the required permissions.
Right now the From path, To path, and extension filter are all hard-coded. If you plan to distribute this or will be using it yourself in multiple locations, you could use the BrowseForFolder method to present the user with a folder browser dialog and allow them to select the From and To folders. You could also use InputBox to get a filter from the user. Just a thought.
Anyways, here is what I did with your code. I changed the variable names to my naming convention simply because that is what I'm used to - you can change them however you want.
Option Explicit
Public Sub CopyPasteFiles()
'Declare variables
Dim SRfso As Scripting.FileSystemObject
Dim strFrom As String
Dim strTO As String
Dim strExtFilter As String
Dim SRfolderA As Scripting.Folder
Dim SRfolderB As Scripting.Folder
'Are you always going to hardcode these or do you want to be able to browse for a folder?
strFrom = "C:\Users\Run" '<< Change
strTO = "C:\Users\Test" '<< Change
'I'm not sure what your intent is with this - I assumed you wanted to filter by file extension.
strExtFilter = "*BT.CSV"
'Prep the folder path
If Right(strFrom, 1) <> "\" Then
strFrom = strFrom & "\"
End If
'Intialize the FileSystemObject
Set SRfso = New Scripting.FileSystemObject
'Verify input and output folders exist. Inform user if they don't.
If SRfso.FolderExists(strFrom) = False Then
MsgBox strFrom & " doesn't exist"
Exit Sub
End If
If SRfso.FolderExists(strTO) = False Then
MsgBox strTO & " doesn't exist"
Exit Sub
End If
'Get the input folder using the FileSystemObject
Set SRfolderA = SRfso.GetFolder(strFrom)
'Call the routine that copies the files
MoveTheFiles SRfolderIN:=SRfolderA, strFolderOUT:=strTO ', strExtFilter:=strExtFilter
'Inform the user where they can find the files. CAUTION: You may be misinforming the user.
MsgBox "You can find the files from " & strFrom & " in " & strTO
End Sub
Private Sub MoveTheFiles(ByRef SRfolderIN As Scripting.Folder, _
ByRef strFolderOUT As String, _
Optional ByRef strExtFilter As String = "*.*", _
Optional ByRef blnSUBFOLDERS As Boolean = True)
'This routine copies the files. It requires two arguments. First, it requires the root folder as folder object from the scripting library. _
Second, it requires the output path as a string. There are two optional arguments. The first allows you _
to use a text filter as a string. The second is a boolean that tells us whether or not to move files in subfolders - the default is true.
'Delcare variables
Dim SRfileA As Scripting.File
Dim SRfolderCol As Scripting.Folders
Dim SRfolderA As Scripting.Folder
Dim datCreated As Date
Dim lngFX As Long
Dim blnResult As Boolean
'Find the file extension in the filter
lngFX = InStrRev(strExtFilter, ".", , vbTextCompare)
'Move the files from the root folder
For Each SRfileA In SRfolderIN.Files
'Only work with files that contain the filter criteria
If Ucase(Mid(SRfileA.Name, InStrRev(SRfileA.Name, ".", , vbTextCompare) - (Len(strExtFilter) - lngFX) + 1, Len(strExtFilter))) Like Ucase(strExtFilter) Then
'Only work with files that were created within the last 100 days
datCreated = SRfileA.DateCreated
If datCreated <= Now And (datCreated >= DateAdd("d", -100, Now())) Then
SRfileA.Copy strFolderOUT
End If
End If
Next
'Check if the calling procedure indicated we are supposed to move subfolder files as well
If blnSUBFOLDERS Then
'Check that we have subfolders to work with
Set SRfolderCol = SRfolderIN.SubFolders
If SRfolderCol.Count > 0 Then
For Each SRfolderA In SRfolderIN.SubFolders
MoveTheFiles SRfolderIN:=SRfolderA, strFolderOUT:=strFolderOUT, strExtFilter:=strExtFilter, blnSUBFOLDERS:=blnSUBFOLDERS
Next
End If
End If
End Sub