CODEWITHSUNDEEP
vba
Robert
Robert

Reputation: 27

Code problem with a format of files which the loop goes over

I have a problem with a VBA code. The macro below is suppose to go to the destination folder which contains only Excel file but with different extension (xls, xlsx, xlsm) and loop over the exising files to find the larges number within the names of the files (the exaples of current files are DelKra 2021-()-162.xls; DelKra 2021-()-163.xls; DelKra 2021-()-164.xlsm). The macro run smoothly only when the destination folder contains xls Excel files but crashes whenever another type of Excel file is saved in the folder. The command the macro crashes at is: "CurrentNum = Mid(FileName, Len(FileName) - 6, 3)". Please help me to fix my macro.*

Sub ConfirmAndSaveDel()
    DestinationFolder = "\\oscwawfs01.kingfisherasia.com.hk\common\FINANCE\Public\BUSINESS 
    TRIPS\Business Trip Delegacje\2021\Domestic\"

    Dim FileArray() As Variant
    Dim FileCount As Integer
    Dim FileName As String
    Dim LastNum As Integer
    Dim CurrentNum As Integer
    Dim Numerek As String
    
    Dim whereTrip As String
    Dim purposeTrip As String
    Dim whoTrip As String
    Dim startTrip As Date
    Dim endTrip As Date
    Dim LastRow As Integer
    
    LastNum = 0
    FileCount = 0
    FileName = Dir(DestinationFolder)
    
'Loop searching all files
    Do While FileName <> ""
        FileCount = FileCount + 1
        ReDim Preserve FileArray(1 To FileCount)
        FileArray(FileCount) = FileName
'Take from the file name numbers 6,5 i 4 counting from the right
        CurrentNum = Mid(FileName, Len(FileName) - 6, 3)
'If it is larger than the current one remember it
            If CurrentNum > LastNum Then
            LastNum = CurrentNum
            End If

'Debug.Print FileName
    FileName = Dir()
        Loop
  
'Add 1 to the largest number found 
    LastNum = LastNum + 1
'Debug.Print LastNum

'Change the numer to string and add as many zeros at the beginning of the number to have it as the three digit number
    If Len(Trim(CStr(LastNum))) = 1 Then
    Numerek = "00" & CStr(LastNum)
    ElseIf Len(Trim(CStr(LastNum))) = 2 Then
    Numerek = "0" & CStr(LastNum)
    ElseIf Len(Trim(CStr(LastNum))) = 3 Then
    Numerek = CStr(LastNum)
        End If

'Combine the whole name of the new file 
    NazwaPliku = "DelKra 2021-" & "(" & Range("FRIFAR").Value & ")-" & Numerek

Upvotes: 0

Views: 52

Answers (2)

FaneDuru
FaneDuru

Reputation: 42256

Try using such a function:

Function extractNumber(strName As String) As Long
    Dim arr: arr = Split(strName, "-")    
    extractNumber = Split(arr(Ubound(arr)), ".")(0)
End Function

Copy the above function in the same module and call it as:

CurrentNum = extractNumber(fileName)

I mean, replace CurrentNum = Mid(FileName, Len(FileName) - 6, 3) with the above way. It is independent of extension number of characters.

And besides that, please replace all declarations As Integer with As Long. In VBA that way of declaring does not bring any benefit in terms of memory handling or from any other point of view... It is good to cultivate such a habit in all cases. But if you like your way, please adapt the function to return As Integer...

Upvotes: 0

FunThomas
FunThomas

Reputation: 29592

The following function will extract the part of the filename between the last dash and the last dot of the filename. If it is numeric, it will return that number, else (or if the filename doesn't follow the pattern) 0.

Function getFileNumber(filename As String) As Long
    
    Dim pDash As Long, pDot As Long
    pDash = InStrRev(filename, "-")
    pDot = InStrRev(filename, ".")
    
    If pDash = 0 Or pDot = 0 Or pDot < pDash Then Exit Function
    Dim suffix As String
    suffix = Mid(filename, pDash + 1, pDot - pDash- 1)
    If IsNumeric(suffix) Then
        getFileNumber = Val(suffix)
    End If
End Function

Upvotes: 0

Related Questions