Code Tweak that Copies data from closed workbooks

[asalazar]

Hello,

I have the following code that works that essentially copies and pastes from multiple closed workbooks into a workbook of my choice. I need some assistance in tweaking the code to allow a user to select a user folder of their choice instead of hard coding the folder path in the VBA code:

Here is my code that works as of now:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Dim LastRow As Long
    
    Set wkbDest = ThisWorkbook
    
    With ActiveSheet
        Rows("2:" & .Rows.Count).Delete
    End With
     
    Const strPath As String = "C:\Users\rbacus\Desktop\reports\"
    ChDir strPath
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
       Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            LastRow = .Sheets(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Sheets(1).Range("A2:F" & LastRow).Copy wkbDest.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Close savechanges:=False
        End With
        
        With wkbSource
            LastRow = .Sheets(2).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Sheets(2).Range("A2:E" & LastRow).Copy wkbDest.Sheets(2).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Here is how I am trying to tweak the code, but I need some help on as the below is not working properly:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Dim LastRow As Long
    
    Set wkbDest = ThisWorkbook
    
    With ActiveSheet
        Rows("2:" & .Rows.Count).Delete
    End With
    
     Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
   
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
       Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            LastRow = .Sheets(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Sheets(1).Range("A2:F" & LastRow).Copy wkbDest.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Close savechanges:=False
        End With
        
        With wkbSource
            LastRow = .Sheets(2).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Sheets(2).Range("A2:E" & LastRow).Copy wkbDest.Sheets(2).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[asalazar]

Ignore this Post, Need Rethink What I am Asking

Ignore this Post, Need Rethink What I am Asking