Hello everyone.
I would like to ask you if you could tell me what put in my macro to do the following:
I have a workbook named "Ivan Ivanov" - as I pressed the button the macro to save in the same folder, but with a 1 next to the name (Ivan Ivanov 1). Ie every time you open the workbook "Ivan Ivanov" and give him a save to continue with one number up -> (Ivan Ivanov 2) (Ivan Ivanov 3), (Ivan Ivanov 4), and so each time.
Thanks in advance
Code:Sub saveProgressiveNumber()
Dim fs, snum As String
Set fs = CreateObject("Scripting.FileSystemObject")
Fname = " Ivan Ivanov "
fpath = "your path"
If Dir(fpath & "*.xls*") = "" Then
ThisWorkbook.SaveAs (fpath & Fname & "0001.xlsm")
Else
Set f = fs.GetFolder(fpath)
Set NFile = f.Files
For Each pf1 In f.Files
date3 = pf1.DateLastModified
Fname1 = pf1.Name
If MDataUM < date3 Then
FpathName = pf1
MDataUM = date3
fnameExt = Fname1
End If
Next
fnum = Val(Mid(FpathName, InStr(FpathName, "-") + 1, 4)) + 1
snum = Format(fnum, "0000")
ThisWorkbook.SaveAs (fpath & Fname & snum & ".xlsm")
End If
End Sub
Hi
Not sure about this. BACKUP your original file before trying this solution.
Put this code in the workbook module.
Code:Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim NewName As String
Dim iNum As Long
Dim OldName As String
Dim FileF As Long
Dim FileNm As String
Const FName As String = "Ivan Ivanov"
With ThisWorkbook
OldName = .FullName
FileF = .FileFormat
FileNm = Left$(.Name, InStrRev(.Name, ".") - 1)
iNum = Mid(FileNm, Len(FName) + 1)
NewName = .Path & Application.PathSeparator & FName & iNum + 1 & ".xlsm"
Application.DisplayAlerts = False
Application.EnableEvents = False
.ChangeFileAccess xlReadOnly
FileCopy OldName, NewName
End With
Application.DisplayAlerts = True
Application.EnableEvents = True
Kill OldName 'comment this line if you want to keep the old file
ThisWorkbook.Close 0
End Sub
Hello friends, thank you very much, but something happened to me things.
patel - your code is great, but these quotes for the path to the folder I received, ie "your path" replace it with "C:\xxxxx\xxxxxx\my folder name\" but always sends me the new file "ivan Ivanov 0001 "in My Documents, and not where I asked him the way. Where is the mistake?
Admin - want to keep the old (original file) and gives me an error in the code.
Ie it can explain a little more - on my desktop I have a folder and it is this excel file "Ivan Ivanov" when I open start to write things in the tables and then press the button makes another file duplicate of the first but with 1 (ivan Ivanov 1), and so with each successive number 1 above.
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHACode:Fname = "Ivan Ivanov " '--------- without initial space
fpath = "your path\"
https://www.youtube.com/watch?v=QjEWAJ3d-jw
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgwCGCesYkcmCcv7tzx4AaABAg
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgwCGCesYkcmCcv7tzx4AaABAg.9wbCfWMaaLa9wbLcU jbPCV 3
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgwCGCesYkcmCcv7tzx4AaABAg.9wbCfWMaaLa9wbLma sNyaX 1
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgzxkJD1jksXet8AZYB4AaABAg.9p3jaxCq0AG9wbF__ jtm9w 2
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxePNoJ9lMOZZIxSI54AaABAg.9n_K6OLzSGt9wbFsa Pa2ym 1
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgwUIM7LhCvJkBpHL4N4AaABAg.9j-vSfzAHrw9wbFzCwVRUo 1
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgwQ_hGXSa1PNKbT-r94AaABAg.9hmiz-Qc-bq9wbG1qa8wKO 1
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgwqWxGrYGjtUAJG6aF4AaABAg.9hI9sgAhykQ9wbG4K JfN91 1
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJL5BeSLbJ-m7BWW54AaABAg.9euWbYmFb169wbG8eMb5Wb 1
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgwaEHwTeazYGD7xHmN4AaABAg.9eWJC0jtPrJ9wbGCR m3IO6 1
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgySibJeWUXeEn3qez14AaABAg.9dj9CcZAzcq9wbGH5 FhlqO
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgyrMrxE5-AP81sgU8V4AaABAg.9aoKBx9yaE89wbGOGcNnKy 1
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=Ugw5b6kCEckEbGTccxp4AaABAg.9_Sbwexq-co9wbGW8LbhKp 1
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgyCQp_ShaVxQui5hJh4AaABAg.9ZBRfgBVmcd9wbGdP 0tnCi 2
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=Ugz_lKW2DNBax4Aemst4AaABAg.9Xjhb-fv4pt9wbGgysEibx
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxguKtw3d8jE8bkGTB4AaABAg.9UuGKC386629wbGl3 2wvjC 1
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgwLt2hK6AcHVnVlaUl4AaABAg.9HKd-ioHqxM9wbH2o6HYsJ 1
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=Ugw-IPT7RwxyRo4cbqd4AaABAg.9GqtD5j30Wp9wbH6q7RTJa 1
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgzLnQG1_LQtmvLQoot4AaABAg.9FvawuMTb-k9wbHFrsug5Z 1
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=Ugys6Ur7BNsRFbH_f_B4AaABAg.9DhZy5EEpKY9wbHfy JkVMG 3
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wbILDvziWr 2
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgwgzeOLschepoIO3gx4AaABAg.97v7ND4_6p298-gyUz3MY7 2
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
comment the line starts with KillQuote:
Admin - want to keep the old (original file)
patel - that pictures what is happening and he did not want to work on reaching the "save".
Attachment 980
Attachment 981
Admin - I do not know what it is asking, but put it this way: - Write in "Ivan Ivanov" save the new file "Ivan Ivanov 1" and the original "Ivan Ivanov" keeps writing until (the latter written in this excel file)
Code:Sub saveProgressiveNumber()
Dim fs, snum As String
Set fs = CreateObject("Scripting.FileSystemObject")
Fname = "Ivan Ivanov-" ' the name must end with -
fpath = "your path\"
If Dir(fpath & "*.xls*") = "" Then
ThisWorkbook.SaveAs (fpath & Fname & "0001.xlsm")
Else
Set f = fs.GetFolder(fpath)
Set NFile = f.Files
For Each pf1 In f.Files
date3 = pf1.DateLastModified
Fname1 = pf1.Name
If MDataUM < date3 Then
FpathName = pf1
MDataUM = date3
fnameExt = Fname1
End If
Next
fnum = Val(Mid(FpathName, InStr(FpathName, "-") + 1, 4)) + 1
snum = Format(fnum, "0000")
ThisWorkbook.SaveAs (fpath & Fname & snum & ".xlsm")
End If
End Sub
another option
Code:Sub saveProgressiveNumber1()
Dim newFileName As String, strPath As String
Dim strFileName As String, strExt As String
strPath = "C:\Users\ivan\Desktop\" 'Change to suit
strFileName = "Ivan Ivanov"
strExt = ".xlsm" 'Change to suit
newFileName = strFileName & "-" & GetNewSuffix(strPath, strFileName, strExt) & strExt
ActiveWorkbook.SaveCopyAs strPath & newFileName
End Sub
Function GetNewSuffix(ByVal strPath As String, ByVal strName As String, ByVal strExt As String) As Integer
Dim strFile As String, strSuffix As String, intMax As Integer
strFile = Dir(strPath & "\" & strName & "*")
Do While strFile <> ""
strSuffix = Mid(strFile, Len(strName) + 2, Len(strFile) - Len(strName) - Len(strExt) - 1)
If Mid(strFile, Len(strName) + 1, 1) = "-" And CSng(strSuffix) >= 0 And _
InStr(1, strSuffix, ",") = 0 And InStr(1, strSuffix, ".") = 0 Then
If CInt(strSuffix) >= intMax Then intMax = CInt(strSuffix)
End If
strFile = Dir
Loop
GetNewSuffix = intMax + 1
End Function
Something is wrong in the code at the picture that I attach opened for the second time the original file "Ivan Ivanov" and when I press tells me that there is already such a file, and if I want to replace it, but it should save it as "Ivan Ivanov-0002".
Ie my idea is every time I open the original file and pressed the button to save the same name but with a number up (one number up) -> Ivan Ivanov-0001, a second file to be - Ivan Ivanov-0002, a third - ivan Ivanov-0003 and so every time. Not like now to save on old Ivan Ivanov-0001. :)
Attachment 982
The second macro that offered me gives me an error like "mish mash" in this line:
And another thing if the file is (.xls), then the code itself should only change this -> ".xlsm" on ".xls"Code:If Mid(strFile, Len(strName) + 1, 1) = "-" And CSng(strSuffix) >= 0 And _
InStr(1, strSuffix, ",") = 0 And InStr(1, strSuffix, ".") = 0 Then
if you are using xls file you have to change this line
toCode:strExt = ".xlsm" 'Change to suit
Code:strExt = ".xls" 'Change to suit
Okay, I guess it must be done to change the formats. - This is great.
What do you say about the other problem - shown in the picture?
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://eileenslounge.com/viewtopic.php?p=244184#p244184
https://eileenslounge.com/viewtopic.php?p=246586#p246586
https://eileenslounge.com/viewtopic.php?p=246112#p246112
https://eileenslounge.com/viewtopic.php?p=246112#p246112
https://eileenslounge.com/viewtopic.php?p=245761#p245761
https://eileenslounge.com/viewtopic.php?p=245722#p245722
https://eileenslounge.com/viewtopic.php?p=245616#p245616
https://eileenslounge.com/viewtopic.php?p=247043#p247043
https://www.excelfox.com/forum/showthread.php/2307-VBA-Range-Sort-with-arrays-Alternative-for-simple-use
https://eileenslounge.com/viewtopic.php?p=245238#p245238
https://eileenslounge.com/viewtopic.php?p=245131#p245131
https://eileenslounge.com/viewtopic.php?f=18&t=31638
https://eileenslounge.com/viewtopic.php?p=244579#p244579
https://eileenslounge.com/viewtopic.php?p=244648#p244648
https://eileenslounge.com/viewtopic.php?p=244647#p244647
https://eileenslounge.com/viewtopic.php?p=244577#p244577
https://eileenslounge.com/viewtopic.php?p=245201#p245201
https://eileenslounge.com/viewtopic.php?p=243975#p243975
https://eileenslounge.com/viewtopic.php?p=243884#p243884
https://eileenslounge.com/viewtopic.php?p=242439#p242439
https://eileenslounge.com/viewtopic.php?p=243595#p243595
https://eileenslounge.com/viewtopic.php?p=243589#p243589
https://eileenslounge.com/viewtopic.php?p=243589#p243589
https://eileenslounge.com/viewtopic.php?p=243002#p243002
https://www.eileenslounge.com/viewtopic.php?p=242761#p242761
https://eileenslounge.com/viewtopic.php?p=242459#p242459
https://eileenslounge.com/viewtopic.php?p=242054#p242054
https://eileenslounge.com/viewtopic.php?p=241404#p241404
https://eileenslounge.com/viewtopic.php?p=229145#p229145
https://eileenslounge.com/viewtopic.php?p=228710#p228710
https://eileenslounge.com/viewtopic.php?p=226938#p226938
https://eileenslounge.com/viewtopic.php?f=18&t=28885
https://eileenslounge.com/viewtopic.php?p=222689#p222689
https://eileenslounge.com/viewtopic.php?p=221622#p221622
https://eileenslounge.com/viewtopic.php?f=27&t=22512
https://eileenslounge.com/viewtopic.php?f=26&t=26183
https://eileenslounge.com/viewtopic.php?f=26&t=26030
https://eileenslounge.com/viewtopic.php?p=202322#p202322
https://www.excelforum.com/word-formatting-and-general/1174522-finding-a-particular-word-phrase-in-word.html#post4604396
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
are you working with last version ? I don't think
Hi, Pleace see post №10. There are the problem in the picture.
I use excel 2003 and excel 2007.
Thank you.
For last version I mean the last code I pasted
Hi, I'm totally confused.
What you can not understand me and what is the last of what you write.
Penultimate and last macro work, but if once has stored in a new file in our example Ivan Ivanov 0001 or Ivan Ivanov-1 or Ivan Ivanov 1 - it does not matter, then stored on it my friend, and I want to create a new file with a serial number, and I can not do anything, if you attach an excel file?
Maybe when you run things (code), but to me it does not. I'll try again to explain:
1 Open the "Ivan Ivanov" - write something.
2 Press the "save" I mean macro
3 in my folder already have a new file - "Ivan Ivanov-0001" or "Ivan Ivanov-1" or whatever
4 re-open the "Ivan Ivanov" - write something
5 Press "save" I mean macro
6 in my folder should have a new file, but number 2 - "Ivan Ivanov-0002" or "Ivan Ivanov-2" or whatever it is there
And in my case I hit the macro (button), he replaced it on the old "Ivan Ivanov-0001" or "Ivan Ivanov-1" or whatever it is there
Am I wrong somewhere or code not working?
Thanks in advance
with this code
if you run macro you can save with progressive number, if you want save the original file with original name you have to save it normally.Code:Sub saveProgressiveNumber1()
Dim newFileName As String, strPath As String
Dim strFileName As String, strExt As String
strPath = "C:\Users\ivan\Desktop\" 'Change to suit
strFileName = "Ivan Ivanov" 'Change to suit
strExt = ".xlsm" 'Change to suit
newFileName = strFileName & "-" & GetNewSuffix(strPath, strFileName, strExt) & strExt
ActiveWorkbook.SaveCopyAs strPath & newFileName
End Sub
Function GetNewSuffix(ByVal strPath As String, ByVal strName As String, ByVal strExt As String) As Integer
Dim strFile As String, strSuffix As String, intMax As Integer
strFile = Dir(strPath & "\" & strName & "*")
Do While strFile <> ""
strSuffix = Mid(strFile, Len(strName) + 2, Len(strFile) - Len(strName) - Len(strExt) - 1)
If Mid(strFile, Len(strName) + 1, 1) = "-" And CSng(strSuffix) >= 0 And _
InStr(1, strSuffix, ",") = 0 And InStr(1, strSuffix, ".") = 0 Then
If CInt(strSuffix) >= intMax Then intMax = CInt(strSuffix)
End If
strFile = Dir
Loop
GetNewSuffix = intMax + 1
End Function
Hello, apparently the problem is with me, so I ask you to look at video file that show what's where and how to set my folder after number 1, number 2 is missing.
Don't change anything in Function GetNewSuffix, you can change the path only in the sub
Okay, but if i do not change out my error immediately.
See photo:
Attachment 987
Attachment 986
attach please your file
Hi
You may also try this one.
Code:Sub kTest()
Dim strFName As String
Dim strExtn As String
Dim strPath As String
Dim lngFNum As Long
Dim nmFNum As Name
Const FName = "ivan ivanov"
On Error Resume Next
Set nmFNum = ThisWorkbook.Names("FNum")
On Error GoTo 0
If nmFNum Is Nothing Then
Set nmFNum = ThisWorkbook.Names.Add("FNum", 1, 0)
lngFNum = 1
Else
lngFNum = Evaluate("FNum") + 1
nmFNum.RefersTo = lngFNum
End If
strFName = ThisWorkbook.FullName
strExtn = Mid$(strFName, InStrRev(strFName, "."))
strPath = Left$(strFName, InStrRev(strFName, "\"))
ThisWorkbook.SaveCopyAs strPath & FName & lngFNum & strExtn
End Sub
Yes, yes, this is exactly what I wanted. That's what's
Infinitely many thanks. You are just amazing, so much that I can not even describe it and to express it in words.
Thank you very much. :notworthy::notworthy::notworthy:
Admin - thus giving my reputation, because when you press the asterisk does not allow me to give you the necessary points.
Attachment 990
Admin
very interesting code, can you comment it ?
HiQuote:
Originally Posted by patel
here you go.
Code:Sub kTest()
Dim strFName As String
Dim strExtn As String
Dim strPath As String
Dim lngFNum As Long
Dim nmFNum As Name
Const FName = "ivan ivanov"
On Error Resume Next
Set nmFNum = ThisWorkbook.Names("FNum") 'a defined name
On Error GoTo 0
If nmFNum Is Nothing Then 'for the first time we have to add the name
Set nmFNum = ThisWorkbook.Names.Add("FNum", 1, 0) 'add the defined name for the first time (0 - visible=false)
lngFNum = 1
Else
lngFNum = Evaluate("FNum") + 1 'get the previous number + 1
nmFNum.RefersTo = lngFNum 'assign the new number
End If
strFName = ThisWorkbook.FullName
strExtn = Mid$(strFName, InStrRev(strFName, "."))
strPath = Left$(strFName, InStrRev(strFName, "\"))
ThisWorkbook.SaveCopyAs strPath & FName & lngFNum & strExtn
End Sub
Than you, I understand now, I think it would be better a visible name, very good idea.