Copy File Names where Month and Year Matches

[howard]

I want to Copy all file names starting with "BRQ" in Folder "C:\Purchases New and Used" where the month and year in the file name matches the month and year in Cell I1 on sheet "Macro" and to paste these in I5 onwards on sheet "Macro"

It would be appreciated if someone could amend my code

 Sub CopyFileNames()
    ' Declare variables
    Dim folderPath As String
    Dim fileName As String
    Dim targetSheet As Worksheet
    Dim currentCell As Range
    Dim pasteRange As Range
    Dim filesFound As Boolean
    
    ' Set the folder path
    folderPath = "C:\Purchases New and Used\"
    
    ' Set the target sheet
    Set targetSheet = ThisWorkbook.Sheets("Macro")
    
    ' Set the current cell with the month and year (assuming it's a date)
    Set currentCell = targetSheet.Range("I1")
    
    ' Find the next available cell in column I after I4
    Set pasteRange = targetSheet.Range("I5")
    
    ' Loop through files in the folder
    fileName = Dir(folderPath & "BRQ*.xlsm")
    Do While fileName <> ""
        ' Extract the date from the file name
        Dim fileDate As Date
        Dim fileNameParts() As String
        fileNameParts = Split(fileName, " ")

        ' Check if the file name has the expected number of parts
        If UBound(fileNameParts) >= 7 Then
            ' Try to convert the last two parts to a date
            If IsDate(fileNameParts(UBound(fileNameParts) - 2) & " " & fileNameParts(UBound(fileNameParts) - 1) & " " & fileNameParts(UBound(fileNameParts))) Then
                fileDate = CDate(fileNameParts(UBound(fileNameParts) - 2) & " " & fileNameParts(UBound(fileNameParts) - 1) & " " & fileNameParts(UBound(fileNameParts)))
                
                ' Compare the extracted date with the date in Cell I1
                If Format(fileDate, "mm-yyyy") = Format(currentCell.Value, "mm-yyyy") Then
                    ' Paste the file name in the next available cell in column I
                    pasteRange.Value = fileName
                    filesFound = True
                    ' Move to the next available cell
                    Set pasteRange = pasteRange.Offset(1, 0)
                End If
            End If
        End If
        
        ' Get the next file in the folder
        fileName = Dir
    Loop
    
    ' Display a message if no matching files were found
    If Not filesFound Then
        MsgBox "No matching files found in the specified folder.", vbInformation
    End If
End Sub [code]

 

[skillilea]

Hey Howard. Can you provide a couple file name examples from that directory?

 

[howard]

The Sample files starting with BRQ are:


BRQ Port Edward New and used Items Nov 2023.xlsm
BRQ GT New and used items Nov 2023.xlsm
BRQ Southern Region New and used items Nov 2023.xlsm

 

[skillilea]

Try this. Assuming month and year are always in that position and month is a 3 letter abbreviation and using the 1st of the month.

Public Sub CopyFileNames()

    Dim targetSheet As Worksheet
    Dim folderPath As String, fileName As String
    Dim dateMatch As Date
    Dim pasteRange As Range
    Dim filesFound As Boolean
    Dim fileNameParts As Variant
    Dim year As Integer, month As Integer, offsetVal As Integer
    Dim fileDate As Date
    
    On Error GoTo eh
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    folderPath = "C:\Purchases New and Used\"
    Set targetSheet = ThisWorkbook.Sheets("Sheet8") ' change sheet
    Set pasteRange = targetSheet.Range("I5")
    dateMatch = targetSheet.Range("I1").Value ' 11/1/2023
    
    ' clear any existing file names
    pasteRange.CurrentRegion.ClearContents
    
    fileName = Dir(folderPath & "BRQ*.xlsm")
    Do While fileName <> ""
        
        ' extract the date assuming: BRQ Southern Region New and used items Nov 2023.xlsm
        ' BRQ (0), YEAR UBOUND, MONTH UBOUND-1
        fileNameParts = Split(fileName, " ")
        year = Split(fileNameParts(UBound(fileNameParts)), ".")(0)
        month = AbbreviatedMonthToNumber(fileNameParts(UBound(fileNameParts) - 1))
        fileDate = DateSerial(year, month, 1)   ' assuming you put the first of the month in your cell
        
        If fileDate = dateMatch Then
            pasteRange.Offset(offsetVal).Value = fileName
            offsetVal = offsetVal + 1
        End If

        fileName = Dir
    Loop
    
    ' no files found
    If offsetVal = 0 Then
        pasteRange.Offset(offsetVal).Value = "No files found"
    End If
    
    GoTo out
eh:
    'handle error
out:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    Set targetSheet = Nothing
End Sub

 

[howard]

Many Thanks for the help


I get a run time error I get Sub or function not defined

 month = AbbreviatedMonthToNumber(fileNameParts(UBound(fileNameParts) - 1))

 

[skillilea]

Sorry, here you go

Function AbbreviatedMonthToNumber(ByVal abbrev As String) As Integer
    Dim months As Variant
    months = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
    
    AbbreviatedMonthToNumber = Application.Match(abbrev, months, 0)
End Function

 

[howard]

Thanks for your help-much apreciated