Macro to Limit Selection in Directory

[howard]

I have VBA Code below that copies data for specified files in a directory. I need code amended so as to see these files and the select these manually

It would be appreciated if someone could kindly amend my code

 Sub Open_MultipleFiles()
    Application.DisplayAlerts = False
    Dim LR As Long
    Dim sDirectory As String
    Dim currentDrive As String
    
    ' Save the current drive letter to restore it later
    currentDrive = Left$(CurDir, 2)
    
    ' Set the desired directory
    sDirectory = "C:\Debtors"
    
    ' Change the drive and directory
    ChDrive Left$(sDirectory, 2) ' Change the drive to match the new directory
    ChDir sDirectory ' Change the directory
    
    With Sheets("Imported Data")
        LR = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("A1:I" & LR).ClearContents
    End With

    Dim varFile As String
    Dim nb As Workbook, tw As Workbook, ts As Worksheet
    Dim fileName As String
    Dim validFile As Boolean
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .CutCopyMode = False
    End With
    
    Set tw = ThisWorkbook
    Set ts = tw.ActiveSheet
    
    ' Loop through files in the directory
    varFile = Dir(sDirectory & "\*.xlsm")
    
    Do While varFile <> ""
        fileName = Right(varFile, Len(varFile) - InStrRev(varFile, "\"))

        ' Check if the file name matches any of the specified patterns
        validFile = (fileName Like "Wrolre RT*" Or fileName Like "Wrolre LW*" Or fileName Like "BR1 Sales(Marnws)*")
        
        If validFile Then
            Set nb = Workbooks.Open(fileName:=sDirectory & "\" & varFile, local:=True)
            
            With nb.Sheets("Imported Data")
                .Range("A1:I2000").Copy
                ' Paste values and formats into the destination sheet
                ThisWorkbook.Sheets("Imported Data").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                ThisWorkbook.Sheets("Imported Data").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormats
            End With
            
            nb.Close False
        End If
        
        varFile = Dir ' Get the next file
    Loop
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .CutCopyMode = True
    End With
    
    With Sheets("Imported Data")
        .Range("A1").EntireRow.Delete
    End With
    
    ' Restore the original drive
    ChDrive currentDrive
    
    Application.DisplayAlerts = True
End Sub

 

[nemmi69]

This is how to select a file manually, this could be put in a loop

Sub SelectAFile()


Dim fd As Office.FileDialog
Dim strFile As String
Dim sDirectory As String
Dim currentDrive As String
   
' Save the current drive letter to restore it later
currentDrive = Left$(CurDir, 2)

' Set the desired directory
sDirectory = "C:\Debtors"
Set fd = Application.FileDialog(msoFileDialogFilePicker)
strFile = ""

With fd

    .Filters.Clear
    .Filters.Add "Excel Files", "*.xlsx?", 1
    .Title = "Choose an Excel file"
    .AllowMultiSelect = False

    .InitialFileName = sDirectory

    If .Show = True Then

        strFile = .SelectedItems(1)

    End If

End With

If strFile <> "" Then
    MsgBox "No file selected", vbCritical
    Exit Sub
End If

End Sub

 

[howard]

Thanks. I want to limit selection to these files below

"Wrolre RT*" , "Wrolre LW*" and BR1 Sales(Marnws)*"

 

[nemmi69]

try

Sub SelectAFile()

Dim fd As Office.FileDialog
Dim strFile As String
Dim sDirectory As String
Dim currentDrive As String
Dim FMatch As Boolean
    
' Save the current drive letter to restore it later
currentDrive = Left$(CurDir, 2)

' Set the desired directory
'sDirectory = "C:\Debtors"
sDirectory = "C:\Adump"
Set fd = Application.FileDialog(msoFileDialogFilePicker)
strFile = ""

With fd

    .Filters.Clear
    .Filters.Add "Excel Files", "*.xlsx?", 1
    .Title = "Choose an Excel file"
    .AllowMultiSelect = False

    .InitialFileName = sDirectory

    If .Show = True Then

        strFile = .SelectedItems(1)

    End If

End With

If strFile <> "" Then
    MsgBox "No file selected", vbCritical
    Exit Sub
Else
    FMatch = False
    If InStr(1, "Wrolre RT", strFile) > 1 Then
        FMatch = False
    ElseIf InStr(1, "Wrolre LW", strFile) > 1 Then
        FMatch = False
    ElseIf InStr(1, "BR1 Sales(Marnws)", strFile) > 1 Then
        FMatch = False
    End If
End If
' Check the file matches 1 of 3
If FMatch = False Then
    MsgBox "File selected does not match", vbCritical
    Exit Sub
End If

End Sub

 

[howard]

Thanks for the help. Kindly add my selection to copy and paste and remove unecessry code