Get folder and run Macro

[trprasad78]

hope all doing great

I need small correction in following vba code.
currently i mention the folder path in macro to run instead it has to ask me to choose path (pop up window to select the folder)

please modify the following code

Thank you

Option Explicit

Dim fso As Object
Sub CopytoMasterFile()
   
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.AskToUpdateLinks = False
   
         
       
    Dim folderpath$: folderpath = "G:\Jan'17\"
       
    Set fso = CreateObject("Scripting.FileSystemObject")
   
    If fso.FolderExists(folderpath) Then Call OpenFileandCopy(folderpath)
   
    Set fso = Nothing
   
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
     Application.AskToUpdateLinks = True
End Sub

 

[Hui]

Try:

Sub CopytoMasterFile()
   
   
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Application.AskToUpdateLinks = False
   
   
   
  Dim folderpath$
  folderpath = GetPath
   
  Set fso = CreateObject("Scripting.FileSystemObject")
   
  If fso.FolderExists(folderpath) Then Call OpenFileandCopy(folderpath)
   
  Set fso = Nothing
   
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  Application.AskToUpdateLinks = True
End Sub

Public Function GetPath() As String

  Dim fileName As Variant

  fileName = Application.GetSaveAsFilename(fileFilter:="Folder (*.*), *.*")

  If fileName <> False Then GetPath = fileName

End Function

 

[trprasad78]

Try:

Sub CopytoMasterFile()
  
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Application.AskToUpdateLinks = False
  
  
  
  Dim folderpath$
  folderpath = GetPath
  
  Set fso = CreateObject("Scripting.FileSystemObject")
  
  If fso.FolderExists(folderpath) Then Call OpenFileandCopy(folderpath)
  
  Set fso = Nothing
  
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  Application.AskToUpdateLinks = True
End Sub

Public Function GetPath() As String

  Dim fileName As Variant

  fileName = Application.GetSaveAsFilename(fileFilter:="Folder (*.*), *.*")

  If fileName <> False Then GetPath = fileName

End Function

Thank you so much for quick solution

 

[trprasad78]

Try:

Sub CopytoMasterFile()
 
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Application.AskToUpdateLinks = False
 
 
 
  Dim folderpath$
  folderpath = GetPath
 
  Set fso = CreateObject("Scripting.FileSystemObject")
 
  If fso.FolderExists(folderpath) Then Call OpenFileandCopy(folderpath)
 
  Set fso = Nothing
 
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  Application.AskToUpdateLinks = True
End Sub

Public Function GetPath() As String

  Dim fileName As Variant

  fileName = Application.GetSaveAsFilename(fileFilter:="Folder (*.*), *.*")

  If fileName <> False Then GetPath = fileName

End Function

i need to open the FOLDER not save as window, let me try to change the code

 

[trprasad78]

i used following code its working

Function GetFolder()AsStringDim fldr As FileDialog
Dim sItem AsStringSet fldr = Application.FileDialog(msoFileDialogFolderPicker)With fldr.Title ="Select a Folder".AllowMultiSelect =False.InitialFileName = Application.DefaultFilePathIf.Show <>-1ThenGoTo NextCode
sItem =.SelectedItems(1)EndWith
NextCode:
GetFolder = sItem
Set fldr =NothingEndFunction

 

[Monty]

Hello Trprasad.

Try this!

Sub Get_folder_file_path()
Dim objFSO As Object
Dim objFolder As Object
Dim objSubFolder As Object
Dim i As Integer
Dim flder As FileDialog
Dim Mypath As String
Dim FileName As String
Dim Wkb As Workbook




Set flder = Application.FileDialog(msoFileDialogFolderPicker)
foldername = flder.Show

Worksheets("Macro sheet").Range("B2").Value = flder.SelectedItems(1)
Set objFSO = CreateObject("Scripting.FileSystemObject")

i = 1

Mypath = Worksheets("Macro sheet").Range("B2").Value

FileName = Dir(Mypath & "\*.xlsx", vbNormal)

Do Until FileName = ""
Set Wkb = Workbooks.Open(FileName:=Mypath & "\" & FileName)

    <<<  Your code>>>



Loop

End Sub