Thread: macro to select path to collect data from

Hi , i have a macro , done with the help of this forum that colects data from seeveral files in one folder that is hard coded in the macro, what i would like now is to have the possibility to select the working folder to work
attatched the files i have now

The macro i have is

Sub CollectInfo()
'Author:    Jerry Beaucaire, ExcelForum.com
'Date:      10/21/2010
'Summary:   Collect specific data from all workbooks in a single folder
Dim fPath As String:        fPath = "C:\2010\Test\"      'where files are found
Dim fName As String
Dim wbData As Workbook
Dim wsDest As Worksheet:    Set wsDest = ThisWorkbook.Sheets("stock")
Dim NR As Long:             NR = wsDest.Range("B" & Rows.Count).End(xlUp).Row + 1
Dim LR As Long

Application.ScreenUpdating = False      'speed up macro
fName = Dir(fPath & "*.xls")            'filter for files to open

Do While Len(fName) > 0
    Set wbData = Workbooks.Open(fPath & fName)  'open found file
    With wbData.Sheets("Resumo")
        .Rows(10).AutoFilter
        .Rows(10).AutoFilter Field:=6, Criteria1:=">0.5"
        LR = .Range("A" & .Rows.Count).End(xlUp).Row
        If LR > 10 Then
            wsDest.Range("A" & NR).Value = .[A5]
            wsDest.Range("E" & NR).Value = .[D2]
            .Range("A11:A" & LR & ",F11:F" & LR & ",K11:K" & LR).Copy
            wsDest.Range("B" & NR).PasteSpecial xlPasteValuesAndNumberFormats
            wsDest.Range("F" & NR).Value = .[C*E]
            
        End If
    End With
    wbData.Close False
    NR = Range("B" & Rows.Count).End(xlUp).Row + 1
    fName = Dir
Loop

LR = Range("B" & Rows.Count).End(xlUp).Row
With Range("A1:E" & LR)
    .SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
    .Value = .Value
End With

Run [teorico()]
Run [real()]

Columns.AutoFit
Application.ScreenUpdating = True



End Sub

You can use this code to prompt someone to select a folder:

    Dim folderName As String
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\"
        .Show
        If .SelectedItems.Count > 0 Then
            folderName = .SelectedItems(1)
        Else
            MsgBox "Folder selection cancelled", vbInformation, Title:="Process Cancelled"
            Exit Sub
        End If
    End With

Dom

Not tested but think this should do it:

Sub CollectInfo()

Dim fPath As String
Dim fName As String
Dim wbData As Workbook
Dim wsDest As Worksheet:    Set wsDest = ThisWorkbook.Sheets("stock")
Dim NR As Long:             NR = wsDest.Range("B" & Rows.Count).End(xlUp).Row + 1
Dim LR As Long
   
With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = "C:\"
    .Show
    If .SelectedItems.Count > 0 Then
        fPath = .SelectedItems(1)
    Else
        MsgBox "Folder selection cancelled", vbInformation, Title:="Process Cancelled"
        Exit Sub
    End If
End With

Application.ScreenUpdating = False      'speed up macro
fName = Dir(fPath & "*.xls")            'filter for files to open

Do While Len(fName) > 0
    Set wbData = Workbooks.Open(fPath & fName)  'open found file
    With wbData.Sheets("Resumo")
        .Rows(10).AutoFilter
        .Rows(10).AutoFilter Field:=6, Criteria1:=">0.5"
        LR = .Range("A" & .Rows.Count).End(xlUp).Row
        If LR > 10 Then
            wsDest.Range("A" & NR).Value = .[A5]
            wsDest.Range("E" & NR).Value = .[D2]
            .Range("A11:A" & LR & ",F11:F" & LR & ",K11:K" & LR).Copy
            wsDest.Range("B" & NR).PasteSpecial xlPasteValuesAndNumberFormats
            wsDest.Range("F" & NR).Value = .[C*E]
            
        End If
    End With
    wbData.Close False
    NR = Range("B" & Rows.Count).End(xlUp).Row + 1
    fName = Dir
Loop

LR = Range("B" & Rows.Count).End(xlUp).Row
With Range("A1:E" & LR)
    .SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
    .Value = .Value
End With

Run [teorico()]
Run [real()]

Columns.AutoFit
Application.ScreenUpdating = True

End Sub

Dom

Small but important correction to this line:

fName = Dir(fPath & "\*.xls")            'filter for files to open

Dom

It should either select the displayed folder or if you highlight one include that.

Noticed this will need changing as well though:

    Set wbData = Workbooks.Open(fPath & "\" & fName)  'open found file

Dom