• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 8748
  • Last Modified:

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
0
ark989
Asked:
ark989
  • 4
  • 2
1 Solution
 
jeveristCommented:
Hi ark989,

>  path should be in the excel sheet

Sure!  Change this:

fld = "C:\Documents and Settings\arkovvur\Desktop\week1"

to this:

' Change 'A3' to whatever cell in the ActiveSheet has the valid folder path
fld = ActiveSheet.Range("A3")

Make sure that whatever cell you use to hold the folder name contains a valid path.

Jim
0
 
Curt LindstromCommented:
You could also modify the start of your macro like this:

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 = Application.GetOpenFilename( _
    Title:="Please select any file from the folder that contains the data, then click Open.")
fld = "C:\Documents and Settings\arkovvur\Desktop\week1"
fld = fld & Application.PathSeparator


BR,
Curt
0
 
ark989Author Commented:
Thanks alot jeverist
Can you please help mewiht pivot chart Q :) if you have time
0
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
ark989Author Commented:
curt,
the code selects only file sand not complete directory:(
thanks for the effort.
ark989
0
 
ark989Author Commented:
Jim,

Also i get an error at these lines when i run the macro second time after running it first time.:(
can you check it
ark989
0
 
ark989Author Commented:
       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
i find the errors at the above lines
0
 
Curt LindstromCommented:
I mucked it up a bit. I know the question is closed now but maybe something like this could be useful for you. Instead of updating the Excel file everytime you need a different path this will allow you to select the path instead. Select any file in the directory you select. Only the path will be saved now :)


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, flName AS String, fil As String, i As Long, j As Long

With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With
flName = Application.GetOpenFilename( _
    Title:="Please select any file from the folder that contains the data, then click Open.")
For j = Len(flName) To 1 Step -1
    If Mid(flName, j, 1) = "\" Then Exit For
Next j
fld = Left(flName, j)

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
.
.
.

BR,
Curt
0

Featured Post

Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 4
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now