How to save excel file with incrementing number? - excel

I am looking for VBA to add to my macro that will increment the file name if the file name already exists.
Current Code:
Dim filepath As String
Dim filename As String
Dim filepatharch As String
Dim filedate As String
Dim filelist As String
'Grab FROM list number
Sheets("TD File").Select
Range("G4").Select
filelist = ActiveCell.Value
'Grab today's date
filedate = Format(Now, "MMDD01.") --------------Currently where the '01' comes from (see below)
'Set where to save and the file naming convention
filepath = "\\home\serverfolder\FileDrop\"
tdfilename = "TD" & filedate & filelist
'& ".txt"
'Set where to save and the file naming convention
filepatharch = "\\home\myfolder\archive"
tdfilename = "TD" & filedate & filelist
'& ".txt"
'Save THXXXXXX.XXX & TDXXXXXX.XXX as flat files
'Workbooks("MYWORK01").Activate
Sheets("TDflatfile").Copy
ActiveWorkbook.SaveAs filename:= _
"\\home\serverfolder\FileDrop\" & tdfilename, FileFormat:=xlCSV, _
CreateBackup:=False
ActiveWindow.Close
An example of the saved file name would be "TD101401.600". TD + MMDD + 01 + .XXX. I would like the "+ 01 " to be the number that increments, that way I could have a file that is "TD101402.600" and so forth. Currently if the file exists for the same .XXX number and date combo, it gets overwritten. The .XXX cannot be the increment.
Is this possible?

Someone suggested this and it worked for me:
Dim filecount As Integer
Do While Len(Dir(filepatharch & thfilename)) <> 0
filecount = filecount + 1
filedate = Format(Now, "MMDD0" & filecount & ".")
tdfilename = "TD" & filedate & filelist
thfilename = "TH" & filedate & filelist
Loop

Just put a conditional loop with Dir()
Do While ((Dir(filepath & tdfilename)) <> Empty)
inc = inc+1
filedate = Format(Now, "MMDD") & "." & Format(inc, "00")
tdfilename = "TD" & filedate & filelist
Loop

Related

Save the file to the corresponding folder based on month and year

I create a new file every day that is named based on the previous business day
It looks like "mmddyyyy ENCORE and Floor". It's a csv file and I need to convert it to xlsm
This code successfully saves my file with the correct name and file type but I need it to save to a different place on my computer with folders based on months:
ActiveWorkbook.SaveAs Filename:="C:\Users\Sarajevo2022\Downloads\" & _
Format(Evaluate("Workday(today(),-2)"), "mmddyyyy") & _
" ENCORE and Floor", FileFormat:=52
The correct file path looks like this:
C:\Users\Sarajevo2022\Company Name\Coworker - OCC ENCORE\2022\Dec 2022
Any direction?
Save As Macro-Enabled Workbook
Sub SaveAsMacroEnabled()
' Build the folder path.
Dim FolderLeft As String: FolderLeft = "C:\Users\Sarajevo2022"
' or:
'Dim FolderLeft As String: FolderLeft = Environ("USERPROFILE")
Dim FolderMid As String: FolderMid = "\Company Name\Coworker - OCC ENCORE\"
Dim SaveDate As Date: SaveDate = Application.WorkDay(Date, -2)
Dim FolderRight As String: FolderRight = Format(SaveDate, "yyyy") _
& "\" & UCase(Format(SaveDate, "mmm yyyy")) & "\"
Dim FolderPath As String: FolderPath = FolderLeft & FolderMid & FolderRight
' Check if the folder path exists.
Dim PathExists As Boolean
With CreateObject("Scripting.FileSystemObject")
PathExists = .FolderExists(FolderPath)
End With
If Not PathExists Then
MsgBox "The path '" & FolderPath & "' doesn't exist!" _
& vbLf & vbLf & "File not saved!", vbCritical
Exit Sub
End If
' Build the file path.
Dim FilePath As String: FilePath = FolderPath _
& Format(SaveDate, "mmddyyyy") & " ENCORE and Floor" & ".xlsm"
' Return the paths in the Immediate window (Ctrl+G).
Debug.Print FolderPath & vbLf & FilePath
' After you have confirmed that the paths are correct,
' out-comment the previous and uncomment the next line.
'ActiveWorkbook.SaveAs FilePath, xlOpenXMLWorkbookMacroEnabled ' or 52
End Sub

Save workbooks with numbers from 1 to 100

I am looking for a way to save my files and add a count after each file, so file 1, next file will have 2 at the end of it and 3 then 4, and so on
ActiveWorkbook.SaveAs "C:\Martin\1BankFiles\Recon" & " " & Format(Now(), "DD-MMM-YYYY") & ".XLSX", FileFormat:=51
what to add to the above VBA code to achieve so.
You need a way to figure out which was the last file written (and if it was written today or earlier).
As your macro stops, using a global variable is not reliable. I guess the easiest way would be to look into the folder where you write the files.
The following function will do exactly that: look for all files with the current date in the file name, figure out the highest number and return the next "free" filename.
Function GetNextFilename()
Const BasePath = "C:\Martin\1BankFiles\"
Dim BaseFilename As String
BaseFilename = "Recon " & Format(Now(), "DD-MMM-YYYY") & "_"
Dim filename As String, filenumber As Long, largestNumber As Long
filename = Dir(BasePath & BaseFilename & "*.xlsx")
Do While filename <> ""
filenumber = Val(Mid(filename, Len(BaseFilename) + 1))
If filenumber > largestNumber Then largestNumber = filenumber
filename = Dir
Loop
GetNextFilename= BasePath & BaseFilename & (largestNumber + 1) & ".xlsx"
End Function
Your Save-commmand would simply be
ActiveWorkbook.SaveAs GetNextFilename, FileFormat:=xlWorkbookDefault

Loop to save worksheet in new workbook

I want to run through a specific sheet (from & to) save those ws as a new file in a folder, if the folder doesn't exist then create.
I'm able to do it to one sheet.
ActiveSheet.Next.Select
If Range("F3").Value = "" Then
Windows("Import OT.xlsm").Activate
Sheets("Cash").Select
Dim filename101 As String
Dim path101 As String
Application.DisplayAlerts = False
path101 = Environ("UserProfile") & "\Dropbox\A271\5 Oppgjor\" & 2020 & "\"
filename101 = Range("B1").Value & ".xlsx"
ActiveWorkbook.SaveAs path101 & Range("A2") & "\" & Range("A1") & " " & filename101,xlOpenXMLWorkbook
Application.DisplayAlerts = True
Else
Cells.Select
Range("F3").Activate
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Dim Path1 As String
Dim fpathname1 As String
Path1 = Environ("UserProfile") & "\Dropbox\A271\4 Lonnslipper\"
fpathname1 = Path1 & Range("F3") & "\" & Range("F2") & " " & Range("B3") & ".xlsx"
path01 = Environ("UserProfile") & "\Dropbox\A271\4 Lonnslipper\" & Range("F3")
Dim path001 As String
Dim Folder As String
Folder = Dir(path01, vbDirectory)
If Folder = vbNullString Then
VBA.FileSystem.MkDir (path01)
ActiveWorkbook.SaveAs filename:=fpathname1, FileFormat:=51
ActiveWorkbook.Close
Sheets("Cash").Select
Else
ActiveWorkbook.SaveAs filename:=fpathname1, FileFormat:=51
ActiveWorkbook.Close
Sheets("Cash").Select
End If
End If
End Sub
I want this as a loop is because I have a few tens of sheets. For it to work I think I need to write it specific time, but with loop I learned I don't need to do that.
Excel file sheet
https://onedrive.live.com/view.aspx?resid=AF6FF2618C09AC74!29027&ithint=file%2cxlsx&authkey=!AHcJjYCu8D0NTNY
According to your comment where you wrote the steps:
Read the comments
Try to run the code using F8 key and see where you need to change it.
As you're learning, please note to first write the steps in plain English Norsk and then develop your code.
See how I just followed your steps with readable code.
Code:
Public Sub GenerateCustomersFiles()
' 1) Active sheet (oppgjør 1-20)
Dim targetSheet As Worksheet
For Each targetSheet In ThisWorkbook.Sheets
' Check only sheets with string in name
If InStr(targetSheet.Name, "Oppgjør") > 0 Then
' 2) look if value in F3 is empty
If targetSheet.Range("F3").Value = vbNullString Then
' 3) if it is, do select "cash" sheet and save this file (its name and path are given above what it should be named)
Dim fileName As String
Dim filePath As String
Dim folderPath As String
folderPath = Environ("UserProfile") & "\Dropbox\A271\5 Oppgjor\" & 2020 & "\"
fileName = targetSheet.Range("B1").Value & ".xlsx"
filePath = folderPath & targetSheet.Range("A2") & "\" & targetSheet.Range("A1") & " " & fileName
ThisWorkbook.Worksheets("Cash").Select
ThisWorkbook.SaveAs filePath, xlOpenXMLWorkbook
Else
' 4) if it doesn't, do open selected sheet to a new workbook and save that in clients name folder (folder and path given above in code section)
folderPath = Environ("UserProfile") & "\Dropbox\A271\4 Lonnslipper\" & targetSheet.Range("F3")
fileName = targetSheet.Range("F2") & " " & targetSheet.Range("B3") & ".xlsx"
filePath = folderPath & "\" & fileName
' 5) check if clients folder exist or not for the file to be saved in.
' if folder doesnt exist,
' create new and save file there.
CreateFoldersInPath folderPath
' if folder exist just save the file there
Dim targetWorkbook As Workbook
Set targetWorkbook = Workbooks.Add
targetSheet.Copy before:=targetWorkbook.Sheets(1)
targetWorkbook.SaveAs filePath, 51
targetWorkbook.Close
End If
End If
Next targetSheet
End Sub
' Credits: https://stackoverflow.com/a/31034201/1521579
Private Sub CreateFoldersInPath(ByVal targetFolderPath As String)
Dim strBuildPath As String
Dim varFolder As Variant
If Right(targetFolderPath, 1) = "\" Then targetFolderPath = Left(targetFolderPath, Len(targetFolderPath) - 1)
For Each varFolder In Split(targetFolderPath, "\")
If Len(strBuildPath) = 0 Then
strBuildPath = varFolder & "\"
Else
strBuildPath = strBuildPath & varFolder & "\"
End If
If Len(Dir(strBuildPath, vbDirectory)) = 0 Then MkDir strBuildPath
Next varFolder
'The full folder path has been created regardless of nested subdirectories
'Continue with your code here
End Sub
Let me know how it goes

duplicate file checking when exporting

can someone tell me what im doing wrong, I am trying to export a file and if the file exists to add duplicate onto the end of it, I cant seem to get it to work
Dim FilePath As String
Dim FileName As String
Dim MyDate As String
Dim megalist As String
Dim FileCopy As String
Dim copy As String
copy = " Duplicate"
FilePath = "Q:\RADIOLOGY\ADMINISTRATION\DATA\CT DISTRIBUTION\PAY ROLL\"
MyDate = Format(Date, "MM-DD-YYYY")
megalist = " Megalist"
FileName = FilePath & MyDate & megalist
FileCopy = FilePath & MyDate & megalist & copy
If Dir(FilePath) <> MyDate & Report Then
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName
Else
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileCopy
End If
End Sub
See below answer to generate your FileName.
https://stackoverflow.com/a/31706252/1684486
and then simply use ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName
EDiT
in your case:
FilePath = "Q:\RADIOLOGY\ADMINISTRATION\DATA\CT DISTRIBUTION\PAY ROLL\"
MyDate = Format(Date, "MM-DD-YYYY")
megalist = " Megalist"
FileName = GetNextAvailableName(FilePath & MyDate & megalist)
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName
of course you need to copy the GetNextAvailableName function from that answer to a public module in your project.

Hyperlink Columns = Excel Macro

I have many pdfs and an excel sheet in one folder. The naming sequence is consistent.
Sheet will be named Apple.
Pdfs will be named Apple_1, Apple_2
I want an excel macro to work
Get the active sheet name.
Hyperlink the cells in G column.
When I click on text in cell 1, it should open Apple_1.pdf
When I click on cell 2, it should open Apple_2.pdf.
This should continue until text filled cells in that column.
I have a Word macro for the same, but I don't know how to make it work in excel. Below is the word macro.
Sub macro3()
Dim tbl As Table
Dim coll As Column
Dim path As String
Dim pdf As String
Dim path1 As String
pdfname = ActiveDocument.Name
pdfname = Left(pdfname, Len(pdfname) - 4)
pdfname = Replace(pdfname, " ", "_")
Set tbl = ActiveDocument.Tables(1)
Set coll = tbl.Columns(7)
Set colpdf = tbl.Columns(7)
i = 0
For Each c In coll.Cells
If (i <> 0 And InStr(c, ".pdf") > 0) Then
path1 = pdfname & "_" & i & ".pdf"
ActiveDocument.Hyperlinks.Add Anchor:=c.Range, Address:=path1
End If
i = i + 1
Next
End Sub
You are missing the directory path to the documents when setting path1. When you click the hyperlink to open its looking in a directory for "Apple1.pdf" which isn't a valid file path. You just need to add the directory path to the start of the path should look like "C:\MyPath\Apple1.pdf".
Your code:
pdfname = ActiveDocument.Name
pdfname = Left(pdfname, Len(pdfname) - 4)
pdfname = Replace(pdfname, " ", "_")
path1 = pdfname & "_" & i & ".pdf"
Solution1: Assuming the documents are in the same folder as activedocument.
Dim MyPath as string
MyPath = ActiveDocument.Path
path1 = MyPath & "\" & pdfname & "_" & i & ".pdf"
Solution2: Files are in another location you can add another string address.
Dim MyPath as string
MyPath = "C:\MyOtherLocation"
path1 = MyPath & "\" & pdfname & "_" & i & ".pdf"

Resources