Using Application. FileDialog(msoFileDialogFolderPicker)

[sanilmathews]

Hello,

I would require some help in changing the code that I have. The below mentioned code picks the value from a particular cells looping through multiple workbooks and populates in the master template. Wherein the master template is saved in the same path where other workbooks are saved. Can I get some help in rewriting the code using "Application. FileDialog(msoFileDialogFolderPicker)" ?

Since saving the master template within the folder where all the workbooks are saved is always not convenient.

Thank you so much in advance.

Sub GetData()
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim r As Long
Set FSO=New Scripting.FileSystemObject
Set SourceFolder=FSO.GetFolder(ThisWorkbook.Path)
r=Range("A65536").End(xlUp).Row+1
Application.ScreenUpdating=False
For Each FileItem In SourceFolder.Files
If FileItem.Name <> ThisWorbook.Name Then
On Error GoTo Errorhandler
Workbooks.Open (ThisWorkbook.Path & Application.PathSeparator & FileItem.Name)
ThisWorkbook.ActiveSheet.Cells(r, 1) = FileItem.Name
ThisWorkbook.ActiveSheet.Cells(r, 2) = Workbooks (FileItem.Name).Sheets(1).Range("A3").Value
ThisWorkbook.ActiveSheet.Cells(r, 3) = Workbooks (FileItem.Name).Sheets(1).Range("A4").Value
Workbooks(FileItem.Name).Close
r=r+1
End If
Next FileItem
Application.ScreenUpdating = True
Columns ("A:B").AutoFit
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
Errorhandler: Exit Sub
End Sub

 

[GWteB]

See if this works for you. Note the separate FolderPicker function.

Public Function FolderPicker() As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
            FolderPicker = .SelectedItems(1)
        End If
    End With
End Function


Public Sub GetData()
    Dim FSO As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    Dim r As Long
        
    Dim sSourcePath As String
    Dim oWb         As Workbook
    
    sSourcePath = FolderPicker
    
    If Len(sSourcePath) > 0 Then
    
        Set FSO = New Scripting.FileSystemObject
        Set SourceFolder = FSO.GetFolder(sSourcePath)
        r = Range("A65536").End(xlUp).Row + 1
        
        Application.ScreenUpdating = False
        With ThisWorkbook
            For Each FileItem In SourceFolder.Files
                If FileItem.Name <> .Name Then
                    On Error GoTo Errorhandler
                    Set oWb = Workbooks.Open(sSourcePath & Application.PathSeparator & FileItem.Name)
                    .ActiveSheet.Cells(r, 1) = FileItem.Name
                    .ActiveSheet.Cells(r, 2) = oWb.Sheets(1).Range("A3").Value
                    .ActiveSheet.Cells(r, 3) = oWb.Sheets(1).Range("A4").Value
                    oWb.Close
                    r = r + 1
                End If
            Next FileItem
        End With
        Application.ScreenUpdating = True
        Columns("A:B").AutoFit
        Set FileItem = Nothing
        Set SourceFolder = Nothing
        Set FSO = Nothing
        
    End If
Errorhandler:       ' Exit Sub (superfluous because of End Sub)
End Sub

 

[Fluff]

How about

Sub GetData()
   Dim Pth As String, Fname As String
   Dim Wbk As Workbook
   Dim r As Long
   With Application.FileDialog(msoFileDialogFolderPicker)
      .AllowMultiSelect = False
      .InitialFileName = ThisWorkbook.Path
      If .Show = -1 Then Pth = .SelectedItems(1)
   End With
   Pth = Pth & Application.PathSeparator

   r = Range("A65536").End(xlUp).Row + 1
   Application.ScreenUpdating = False
   Fname = Dir(Pth & "*.xls*")
   
   On Error GoTo Errorhandler
   Do While Fname <> ""
      If Fname <> ThisWorkbook.Name Then
         Set Wbk = Workbooks.Open(Pth & Fname)
         With ThisWorkbook.ActiveSheet
            .Cells(r, 1) = Fname
            .Cells(r, 2) = Wbk.Sheets(1).Range("A3").Value
            .Cells(r, 3) = Wbk.Sheets(1).Range("A4").Value
         End With
         Wbk.Close False
         r = r + 1
      End If
      Fname = Dir
   Loop
   Columns("A:B").AutoFit
Errorhandler:    Exit Sub
End Sub

 

[sanilmathews]

Hello,

I would require some help in changing the code that I have. The below mentioned code picks the value from a particular cells looping through multiple workbooks and populates in the master template. Wherein the master template is saved in the same path where other workbooks are saved. Can I get some help in rewriting the code using "Application. FileDialog(msoFileDialogFolderPicker)" ?

Since saving the master template within the folder where all the workbooks are saved is always not convenient.

Thank you so much in advance.

Sub GetData()
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim r As Long
Set FSO=New Scripting.FileSystemObject
Set SourceFolder=FSO.GetFolder(ThisWorkbook.Path)
r=Range("A65536").End(xlUp).Row+1
Application.ScreenUpdating=False
For Each FileItem In SourceFolder.Files
If FileItem.Name <> ThisWorbook.Name Then
On Error GoTo Errorhandler
Workbooks.Open (ThisWorkbook.Path & Application.PathSeparator & FileItem.Name)
ThisWorkbook.ActiveSheet.Cells(r, 1) = FileItem.Name
ThisWorkbook.ActiveSheet.Cells(r, 2) = Workbooks (FileItem.Name).Sheets(1).Range("A3").Value
ThisWorkbook.ActiveSheet.Cells(r, 3) = Workbooks (FileItem.Name).Sheets(1).Range("A4").Value
Workbooks(FileItem.Name).Close
r=r+1
End If
Next FileItem
Application.ScreenUpdating = True
Columns ("A:B").AutoFit
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
Errorhandler: Exit Sub
End Sub

Thank you for your response! Works for me.

 

[sanilmathews]

Thanks for your response. Works for me!

 

[Fluff]

You're welcome & thanks for the feedback.