Trouble With Dialog Box Applying to All Files in a Folder

[S_Alvernaz]

Hi Everyone! I am realatively new to VBA and have been piecing together this code from other posted codes. However, I am having trouble with an Application DialogBox

The Project: I am designing a macro for a packing company that allows the user to select a folder and enter a date. The macro will copy all the rows (from the files in the folder the selected using folder picker) matching the entered date to a master spread sheet called the QueenSheet.

The Problem: The macro is only copying and pasting from the first file in the folder, but still opening and closing the following files. When I was first playing around with the inputbox, I put it below "DoEvents" and I had to enter the date for every file in the folder. It would only copy and paste from the first file if I put the same date for all of them, but would copy and paste from all of the files if I entered different dates for each file in the loop.

Sub Link_Data_FromOpenFile_To_QueenSheet()
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim LSearchRow
Dim myDate As String
x = 34
'Optimize Macro Speed but not necessary
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xCalculationManual
    
'Empty previous sheet
    Windows("QueenSheet.xlsm").Activate
    Range("A2:W50").ClearContents
    
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
    With FldrPicker
    .Title = "Select Open Lots Folder "
    .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With


'In Case of Cancel
NextCode:
   myPath = myPath
    If myPath = "" Then GoTo ResetSettings
    myExtension = "*.xls*"
    
'First event is to copy the specific row from each open lot sheet
        myDate = Application.InputBox("Enter Date", "Select Data to view by Date")
'Target Path with Ending Extension
    myFile = Dir(myPath & myExtension)
    
'Loop through each Excel file in folder
Do While myFile <> ""
    'Set variable equal to opened workbook
    Set wb = Workbooks.Open(Filename:=myPath & myFile)
  
    DoEvents
        Do While Cells(x, 1) <> ""
        If Cells(x, 1) = myDate Then
        Rows(x).Copy
        
        'Second event is to paste into the QueenSheet and continue down
        Windows("QueenSheet.xlsm").Activate
        Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial (xlPasteValues)
        Application.CutCopyMode = False
        End If
        x = x + 1
        Loop
 
    'Save and Close Workbook
    wb.Close SaveChanges:=True
    
    'Ensure Workbook has closed before moving on to next line of code
    DoEvents
    
    'Get Next file name
    myFile = Dir
Loop


'Message Box when tasks are completed
MsgBox "All Done! Hit Ok"
    
ResetSettings:
    'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Any help or tips would be greatly appreciated. Thank!
- Suzi

 

[dmt32]

Hi welcome to the Forum

When working across workbooks it is important to properly qualify the worksheets to correct workbook in your code to ensure it all works as required.
It is also useful in these situations to include some error handling to manage a soft exit should anything unforeseen occur.

Untested, but see if my updates to your code help you

Sub Link_Data_FromOpenFile_To_QueenSheet()
    Dim myPath As String, myFile As String
    Dim myExtension As String
    Dim FldrPicker As FileDialog
    Dim x As Long
    Dim myDate As Variant
    Dim wsQueenSheet As Worksheet, wb As Workbook
    
    On Error GoTo ResetSettings


'QueenSheet is first worksheet in thisworkbook (change as required)
    Set wsQueenSheet = ThisWorkbook.Worksheets(1)
    
'Empty previous sheet
    wbQueenSheet.Range("A2:W50").ClearContents
    
'Retrieve Target Folder Path From User
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
    With FldrPicker
        .Title = "Select Open Lots Folder "
        .AllowMultiSelect = False
'In Case of Cancel
        If .Show <> -1 Then GoTo ResetSettings
        myPath = .SelectedItems(1)
    End With
    
    myExtension = "*.xls*"
    myPath = myPath & "\"
    
'First event is to copy the specific row from each open lot sheet
    Do
        myDate = Application.InputBox("Enter Date", "Select Data to view by Date")
'cancel pressed
        If myDate = "False" Then GoTo ResetSettings
    Loop Until IsDate(myDate)
    
    
'Target Path with Ending Extension
    myFile = Dir(myPath & myExtension)
    
'Optimize Macro Speed but not necessary
    With Application
        .ScreenUpdating = False: .EnableEvents = False: .Calculation = xCalculationManual
    End With
    
'Loop through each Excel file in folder
    Do While myFile <> ""
'Set variable equal to opened workbook (readonly as we are just copying from it)
        Set wb = Workbooks.Open(Filename:=myPath & myFile, ReadOnly:=True)
        
'start at row 34
        x = 34


'copy from the first sheet of opened workbook (change as required)
        With wb.Sheets(1)
            Do While .Cells(x, 1) <> ""
            If IsDate(.Cells(x, 1).Text) Then
                If DateValue(.Cells(x, 1).Text) = DateValue(myDate) Then
                    .Rows(x).Copy
                    
'Second event is to paste into the QueenSheet and continue down
                    With wsQueenSheet
                        .Range("A" & .Rows.Count).End(xlUp).Offset(1).PasteSpecial (xlPasteValues)
                    End With
                    Application.CutCopyMode = False
                End If
            End If
                x = x + 1
            Loop
        End With
            
'Close Workbook without saving
            wb.Close False
'release object variable from memory
            Set wb = Nothing
'Get Next file name
            myFile = Dir
        Loop
        
        
ResetSettings:
'Reset Macro Optimization Settings
        With Application
            .EnableEvents = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
        End With
        
'report errors
        If Err > 0 Then
            MsgBox (Error(Err)), 48, "Error"
        ElseIf Len(myPath) > 0 Then
'report success
            MsgBox "All Done! Hit Ok", 48, "All Done"
        End If
End Sub

I have hazard a guess that your code may not have been reading your date values correctly so included some coercing which may or may not help.

Note lines in RED - I have assumed Sheet(1) is the worksheet in each workbook you are copying from / to - update as required.

Hope Helpful

Dave

 

[S_Alvernaz]

Ill give it a go! Thanks!!!!!!!!

 

[dmt32]

Ill give it a go! Thanks!!!!!!!!

Hi,
Thanks for feedback & hope changes help – At later stage, may want to consider changing your Do loop through the range to copy data between workbooks for a Filter which would be much faster.

Dave

 

[S_Alvernaz]

Thanks for all your help, Dave. The code worked like a charm! Ill definetly look into the Do loop as my boss will be running through a lot of data. Again THANK YOU!!

 

[dmt32]

Thanks for all your help, Dave. The code worked like a charm! Ill definetly look into the Do loop as my boss will be running through a lot of data. Again THANK YOU!!

most welcome - thanks for feedback

Dave