Macro to Open File and limit selection where files contains "Parts" in C

[howard]

I have tried to write code to limit files to see in folder C::\Extract and secondly they must be todays date (Date Modified) format is dd/mm/yyyy

The rest of the code works 100%

Kindly amend my code as I cannot get it to limit the selection to only show only files containing "Parts" in the file name of the csv files and date modified ,being todays date

 Sub Open_Workbook()
    Dim nb As Workbook, tw As Workbook, WS As Worksheet, LR As Long, A As Variant
    Dim rngDestination As Range
    Dim filename As Variant
    Dim fileDir As String
    Dim fileItem As String
    Dim fileDate As Date
    Dim fileDateFormat As String
    Dim latestFiles As Collection
    Dim dlg As FileDialog
    Dim i As Integer

    Set WS = ThisWorkbook.Sheets("Imported Data")
    WS.UsedRange.ClearContents

    On Error Resume Next
    Set rngDestination = WS.Range("A1")
    On Error GoTo 0
    If rngDestination Is Nothing Then Exit Sub  'User canceled

    fileDir = "C:\Extract\"
    Set latestFiles = New Collection
    fileDateFormat = Format(Date, "dd-mm-yyyy") ' Format as "dd-mm-yyyy" or "dd/mm/yyyy" depending on your system's settings
    
    ' Loop through all files in the directory
    fileItem = Dir(fileDir & "*Parts*.csv")
    Do While fileItem <> ""
        ' Check if the file is last modified today
        fileDate = FileDateTime(fileDir & fileItem)
        If Format(fileDate, "dd-mm-yyyy") = fileDateFormat Then
            ' Add the file to the collection if it matches the criteria
            latestFiles.Add fileDir & fileItem
        End If
        fileItem = Dir
    Loop

    ' If matching files are found, display the FileDialog for user to select
    If latestFiles.Count > 0 Then
        ' Use the FileDialog to show only matching files
        Set dlg = Application.FileDialog(msoFileDialogFilePicker)
        With dlg
            .Title = "Select CSV file"
            .ButtonName = "Open"
            .AllowMultiSelect = False
            .InitialFileName = fileDir & "*.csv"
            .Filters.Clear
            .Filters.Add "CSV Files with 'Parts' in Name", "*.csv"

            If .Show = -1 Then ' If the user selects a file
                ' Verify that the selected file matches the filter criteria
                filename = .SelectedItems(1)
                If InStr(1, filename, "Parts", vbTextCompare) > 0 And Format(FileDateTime(filename), "dd-mm-yyyy") = fileDateFormat Then
                    
                    Application.ScreenUpdating = False
                    Dim srcWorkbook As Workbook
                    Set srcWorkbook = Workbooks.Open(filename:=filename, local:=True)
                    ThisWorkbook.Activate

                    srcWorkbook.Sheets(1).Range("A:AM").Copy
                    rngDestination.PasteSpecial Paste:=xlPasteValues
                    Application.CutCopyMode = False

                    srcWorkbook.Close SaveChanges:=False
                    Application.ScreenUpdating = True
                Else
                    MsgBox "Selected file does not match the criteria.", vbExclamation
                End If
            Else
                MsgBox "No file was selected.", vbExclamation
            End If
        End With
    Else
        MsgBox "No files matching the criteria found.", vbExclamation
    End If
End Sub

 

[DanteAmor]

I'm not sure you can filter such specific file names with the FileDialog.

But I suggest the following alternative, so that you filter the file names and add them to a list box..
Then with double click you can open the desired file:

Put the following code in ThisWorkbook events:

Private Sub Workbook_Open()
  UserForm1.Show
End Sub

Create a userform and in the code put the following::

Const fileDir = "C:\trabajo\files\"           'At the beginning of all the code

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
  Dim ws As Worksheet
  Dim srcWorkbook As Workbook
  Dim rngDestination As Range

  Application.ScreenUpdating = False
  Application.DisplayAlerts = False

  Set ws = ThisWorkbook.Sheets("Imported Data")
  ws.UsedRange.ClearContents
  Set rngDestination = ws.Range("A1")
  Set srcWorkbook = Workbooks.Open(filename:=fileDir & ListBox1.Value, local:=True)

  srcWorkbook.Sheets(1).Range("A:AM").Copy
  rngDestination.PasteSpecial Paste:=xlPasteValues
  srcWorkbook.Close SaveChanges:=False
  
  Unload Me

  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Private Sub UserForm_Activate()
  Dim fileDateFormat As String
  Dim fileItem As String
  
  fileDateFormat = Format(Date, "dd-mm-yyyy") ' Format as "dd-mm-yyyy" or "dd/mm/yyyy" depending on your system's settings
  
  ' Loop through all files in the directory
  fileItem = Dir(fileDir & "*Parts*.csv")
  Do While fileItem <> ""
    ' Check if the file is last modified today
    If Format(FileDateTime(fileDir & fileItem), "dd-mm-yyyy") = fileDateFormat Then
      ListBox1.AddItem fileItem ' Add the file to the ListBox if it matches the criteria
    End If
    fileItem = Dir
  Loop
End Sub

----- --
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
----- --

 

[howard]

Thanks for your help Dante

I will set up a user form with a a list box test and let you know

 

[howard]

Hi Dante

I made a few minor changes to your code and it works 100%

 See Code for list Box

Private Sub UserForm_Initialize()

Dim ws As Worksheet

Dim rng As Range

Dim cell As Range



' Reference to the sheet and the range containing file names

Set ws = ThisWorkbook.Sheets("Summary")

Set rng = ws.Range("H1:H" & ws.Cells(ws.Rows.Count, "H").End(xlUp).Row)



' Populate the ListBox with file names

Me.ListBox1.Clear ' Clear any existing items

For Each cell In rng

If Not IsEmpty(cell.Value) Then

Me.ListBox1.AddItem cell.Value

End If

Next cell

End Sub



Private Sub OKButton_Click()

' Code to handle the OK button click

Me.Hide ' Hide the UserForm when the OK button is clicked

End Sub

Private Sub CancelButton_Click()

Me.Hide ' Hide the UserForm when the Cancel button is clicked

End Sub

Sub Open_Workbook()
    Dim selectedFile As String
    Dim ws As Worksheet, rngDestination As Range
    Dim srcWorkbook As Workbook
    
    ' Display the UserForm to show the list of files
    ShowFileListForm
    
    ' Check if UserForm was hidden (i.e., the OK button was clicked)
    If UserForm1.ListBox1.ListIndex = -1 Then Exit Sub ' No selection made
    
    ' Construct the full path to the selected file
    selectedFile = "C:\Extract\" & UserForm1.ListBox1.Value
    
    
    Set ws = ThisWorkbook.Sheets("Imported Data")
    ws.UsedRange.ClearContents
    
    On Error Resume Next
    Set rngDestination = ws.Range("A1")
    On Error GoTo 0
    If rngDestination Is Nothing Then Exit Sub  ' User canceled
    
    Application.ScreenUpdating = False
    Set srcWorkbook = Workbooks.Open(filename:=selectedFile, local:=True)
    ThisWorkbook.Activate
    
    srcWorkbook.Sheets(1).Range("A:AM").Copy
    rngDestination.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    
    srcWorkbook.Close SaveChanges:=False
    Application.ScreenUpdating = True
End Sub  [code]

 

[howard]

Hi Dante

It is possible that once the File/s in list box have been selected to then open the dialog box to view these filles to ensure that they are the latest files

 Sub Open_Workbook()
ShowFileListForm
    Dim ws As Worksheet
    Dim srcWorkbook As Workbook
    Dim folderPath As String
    Dim fileName As String
    Dim latestFile As String
    Dim latestDate As Date
    Dim fileDate As Date
    Dim fileDialog As Object
    Dim fso As Object
    Dim folder As Object
    Dim file As Object
    
    ' Set the folder path where the CSV files are located
    folderPath = "C:\Extract\"

    ' Initialize the latest file and date
    latestFile = ""
    latestDate = DateSerial(1900, 1, 1) ' A very old date

    ' Create FileSystemObject to access the folder
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)
    
    ' Loop through each file in the folder
    For Each file In folder.Files
        ' Check if the file is a CSV file
        If LCase(fso.GetExtensionName(file.Name)) = "csv" Then
            ' Get the last modified date of the file
            fileDate = file.DateLastModified
            ' Compare with the latest date found
            If fileDate > latestDate Then
                latestDate = fileDate
                latestFile = file.Path
            End If
        End If
    Next file

    ' If no CSV file was found, show a message and exit
    If latestFile = "" Then
        MsgBox "No CSV files found in the specified folder.", vbExclamation
        Exit Sub
    End If

    ' Clean up and proceed with your existing code
    Set ws = ThisWorkbook.Sheets("Imported Data")
    ws.UsedRange.ClearContents
    
    Application.ScreenUpdating = False
    ' Import the latest CSV file
    With ws.QueryTables.Add(Connection:="TEXT;" & latestFile, Destination:=ws.Range("A1"))
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFilePlatform = xlWindows
        .Refresh
    End With
    Application.ScreenUpdating = True
    
    ' Optionally, you can open the workbook to check
    ' Set srcWorkbook = Workbooks.Open(filename:=latestFile, local:=True)
    ' srcWorkbook.Close SaveChanges:=False
End Sub