Prompt Folder Open via VBA

Viewed 23

I am new to VBA and dont have that much knowledge about coding, Need kind support to open the folder via dialog box instead of giving the source folder path manually in the VBA code (Const FolderA = "Folder Path"). Code works fine with inputting manual path inside the vba code(code copied)

Public Sub MoveFiles()
Const colA = 1
Const colB = 2
Const colC = 3
Const FolderA = "H:\My Drive\Appreciation Certification\Sep 21 2022\QR Code\"    ' source folder
Const srcSheet = "Source"
 
Dim xlS As Excel.Worksheet
Dim xlW As Excel.Workbook
Dim RN As Long              ' row number
Dim fName As String
Dim fPath As String
 
  ' ready 
  Set xlW = ActiveWorkbook
  Set xlS = xlW.Sheets(srcSheet)
   
  RN = 2
  fName = Trim(xlS.Cells(RN, colA).Text)
   
  ' run thru ColA until hit a blank
   
  On Error Resume Next  ' expect problems if no target Dir
         
  While fName <> ""
   
    ' if it hasn't aready been moved
     
    If Trim(xlS.Cells(RN, colC).Text) = "" Then
     
      ' got one.
      ' Get the path.  Ensure trailing backslash
       
      fPath = Trim(xlS.Cells(RN, colB).Text)
       
      If Right(fPath, 1) <> "\" Then fPath = fPath & "\"
       
      ' if the target already exists, nuke it.
       
      If Dir(fPath & fName) <> "" Then Kill fPath & fName
       
      ' move it
       
      FileCopy FolderA & fName, fPath & fName
      DoEvents
       
      ' report it
       
      If Err.Number <> 0 Then
       
        xlS.Cells(RN, colC).Value = "Failed: Check target Dir"
         
        Err.Clear
         
      Else
       
        xlS.Cells(RN, colC).Value = Now()
         
      End If
    End If
     
    ' ready for next one
     
    RN = RN + 1
    fName = Trim(xlS.Cells(RN, colA).Text)
     
  Wend
   
  MsgBox "All files moved!!"
       
End Sub
0 Answers
Related