• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 8751
  • 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
Cloud Class® Course: Amazon Web Services - Basic

Are you thinking about creating an Amazon Web Services account for your business? Not sure where to start? In this course you’ll get an overview of the history of AWS and take a tour of their user interface.

 
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
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Introducing Cloud Class® training courses

Tech changes fast. You can learn faster. That’s why we’re bringing professional training courses to Experts Exchange. With a subscription, you can access all the Cloud Class® courses to expand your education, prep for certifications, and get top-notch instructions.

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