VBA Save file as numbered sequence

[dknipe]

Using VBA, how do I search a folder for files referencing a number (not a cell value) like AK001.txt, AK002.txt etc, and save current worksheet as the next number in sequence eg AK003.txt

 

[NdNoviceHlp]

This seems to work. U will have to change the folder path. I'm not sure about the saveas line of code and this might require change. HTH. Dave

Private Sub test2()
'AK003.txt format
Dim fso As Object, FolDir As Object, FileNm As Object, NumStr As Integer, MaxNum As Integer
Dim NewName As String, FolderStr As String, StrNum As String, MaxStr As String
MaxNum = 1
FolderStr = "C:\YourFolderName\"
Set fso = CreateObject("scripting.filesystemobject")
Set FolDir = fso.GetFolder(FolderStr)
For Each FileNm In FolDir.Files
If FileNm.Name Like "AK" & "*" & ".txt" Then
StrNum = Right(Left(FileNm.Name, 5), 3)
NumStr = CInt(StrNum)
If NumStr > MaxNum Then
MaxNum = NumStr
End If
End If
Next FileNm
MaxStr = CStr(Format(MaxNum + 1, "000"))
NewName = FolderStr & "AK" & MaxStr & ".txt"
'file format????
ActiveWorkbook.SaveAs Filename:=NewName, FileFormat:=xlText, CreateBackup:=False
Set FolDir = Nothing
Set fso = Nothing
End Sub

 

[dknipe]

This seems to work. U will have to change the folder path. I'm not sure about the saveas line of code and this might require change. HTH. Dave

Private Sub test2()
'AK003.txt format
Dim fso As Object, FolDir As Object, FileNm As Object, NumStr As Integer, MaxNum As Integer
Dim NewName As String, FolderStr As String, StrNum As String, MaxStr As String
MaxNum = 1
FolderStr = "C:\YourFolderName\"
Set fso = CreateObject("scripting.filesystemobject")
Set FolDir = fso.GetFolder(FolderStr)
For Each FileNm In FolDir.Files
If FileNm.Name Like "AK" & "*" & ".txt" Then
StrNum = Right(Left(FileNm.Name, 5), 3)
NumStr = CInt(StrNum)
If NumStr > MaxNum Then
MaxNum = NumStr
End If
End If
Next FileNm
MaxStr = CStr(Format(MaxNum + 1, "000"))
NewName = FolderStr & "AK" & MaxStr & ".txt"
'file format????
ActiveWorkbook.SaveAs Filename:=NewName, FileFormat:=xlText, CreateBackup:=False
Set FolDir = Nothing
Set fso = Nothing
End Sub

Thanks for this. I am getting error
[FONT=&quot]ActiveX component can't create object

Not sure if it is cos am on Mac Excel[/FONT]

 

[NdNoviceHlp]

Likely the Mac has something to do with this. The code tested and worked for me on Windows. Dave

 

[dknipe]

Thanks yes doing quick search shows Mac do not have the Scripting Runtime library, so need to come up with an alternative way of doing this that will work for both pc and Mac

 

[NdNoviceHlp]

Perhaps the DIR function will work. It doesn't need the Scripting Runtime library. Dave

Private Sub test()
'AK003.txt format
Dim fso As Object, FolDir As String, FileNm As Object, NumStr As Integer, MaxNum As Integer
Dim NewName As String, StrNum As String, MaxStr As String
Dim FolderStr As String 'Object
MaxNum = 1
FolderStr = "C:\YourFolderName\"
'Set fso = CreateObject("scripting.filesystemobject")
'Set FolDir = fso.GetFolder(FolderStr)
FolDir = Dir(FolderStr)
'For Each FileNm In FolDir.Files
Do While Len(FolDir) > 0
'If FileNm.Name Like "AK" & "*" & ".txt" Then
If FolDir Like "AK" & "*" & ".txt" Then
StrNum = Right(Left(FolDir, 5), 3)
NumStr = CInt(StrNum)
If NumStr > MaxNum Then
MaxNum = NumStr
End If
End If
FolDir = Dir
'Next FileNm
Loop
MaxStr = CStr(Format(MaxNum + 1, "000"))
NewName = FolderStr & "AK" & MaxStr & ".txt"
'file format????
ActiveWorkbook.SaveAs Filename:=NewName, FileFormat:=xlText, CreateBackup:=False
'Set FolDir = Nothing
'Set fso = Nothing
End Sub

 

[dknipe]

Ok got it to do what wanted with this:

Sub Sample()


Dim strPath As String
Dim MyDir As String
Dim strFile As String
Dim StrNum As String
Dim NumStr As Integer
Dim MaxNum As Integer
Dim NewName As String


MaxNum = 1


MyDir = ActiveWorkbook.Path
strPath = MyDir & "/Mileage-Claims/"
strFile = Dir(strPath)


'Loop through each file in the folder
Do While Len(strFile) > 0
If Right(strFile, 4) = "xlsm" Then
StrNum = Right(Left(strFile, 5), 3)
NumStr = CInt(StrNum)
If NumStr > MaxNum Then
MaxNum = NumStr
End If
End If


strFile = Dir
Loop
MsgBox MaxNum

MaxStr = CStr(Format(MaxNum + 1, "000"))
NewName = strPath & "MIL-" & MaxStr & ".xlsm"
MsgBox NewName


End Sub

 

[NdNoviceHlp]

You are welcome. Thanks for posting your outcome. Dave