Macro to get files froma directory

I have a macro which scans all excel  files in a directory. but the path of the directory is in the VB code.
i would like to know if this can be changed. i . e . path should be in the excel sheet (easy for the user to change the path before running the macro).
the macro which i have(credit to jeverist @EE for the code)

Sub CombineFiles()
Dim wb_new As Workbook, ws As Worksheet, ws_o As Worksheet, ws_c As Worksheet, wb As Workbook, sh As Worksheet
Dim rng As Range, cel As Range, fld As String, fil As String, i As Long

With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With

fld = "C:\Documents and Settings\arkovvur\Desktop\week1"
fld = fld & Application.PathSeparator

Set wb_new = Workbooks.Add
If wb_new.Worksheets.Count < 2 Then wb_new.Worksheets.Add
For i = 1 To wb_new.Worksheets.Count
    Select Case i
    Case 1
        Set ws_o = wb_new.Worksheets(i)
        ws_o.Name = "Open"
    Case 2
        Set ws_c = wb_new.Worksheets(i)
        ws_c.Name = "Closed"
    Case Else
        wb_new.Worksheets(i).Delete
    End Select
Next i
       
fil = Dir(fld & "*.xls")
Do While (fil <> "")
    Set wb = Workbooks.Open(fld & fil)
    For Each sh In wb.Worksheets
        Select Case Trim(Left(LCase(sh.Name), 5))
        Case "open"
            Set ws = ws_o
        Case "close"
            Set ws = ws_c
        Case Else
            Set ws = Nothing
        End Select
       
        If Not ws Is Nothing Then
            If ws.UsedRange.Cells.Count = 1 Then
                sh.Rows(3).Copy Destination:=ws.Rows(1)
            End If
           
            Set rng = Range(sh.Cells(5, "A"), sh.Cells(sh.Rows.Count, "A").End(xlUp)).Resize(ColumnSize:=sh.UsedRange.Columns.Count)
           
            If Not rng Is Nothing Then
                With ws.Cells(ws.Rows.Count, "A").End(xlUp)
                    rng.Copy Destination:=.Offset(1)
                End With
            End If
        End If
    Next sh
   
    wb.Close SaveChanges:=False
   
    fil = Dir
Loop

For i = 1 To 2
    Select Case i
    Case 1
        Set ws = ws_o
    Case 2
        Set ws = ws_c
    End Select
   
    With ws
        For Each cel In Intersect(ws.UsedRange, ws.Columns("H")).Cells
            If Trim(cel) = "" Then cel = Date
        Next cel
       
        Union(.Columns("B"), .Columns("D:G")).Delete
       
        With .UsedRange.Columns(Application.CountA(.Rows(1))).Offset(0, 1)
            .FormulaR1C1 = "=RC[-1]-RC[-2]"
            .NumberFormat = "General"
            .Cells(1).Value = "Days Open"
        End With
       
        With .UsedRange.Columns(Application.CountA(.Rows(1))).Offset(0, 1)
            .FormulaR1C1 = "=ROUNDUP(RC[-1]/7,0)"
            .NumberFormat = "General"
            .Cells(1).Value = "Weeks Open"
        End With
       
        With .UsedRange
            .Columns.AutoFit
            .Sort Key1:=.Range("D2"), Order1:=xlDescending, Header:=xlGuess
        End With
    End With
Next i

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

End Sub
Start Free Trial