Giúp sửa code chọn folder trực tiếp không nhập đường dẫn

[nguyenanhdung8111982]

tôi có đoạn code như dưới khi chạy sẽ dựa 3 ký tự đầu bắt đầu từ ký tự thứ 2 tạo thư mục và move những hình có 3 ký tự đầu vào thư mục vừa tạo.
ví dụ: hình nào G0015678,G0015679 thì move vô 001, hình nào G0025678,G0025679 thì move vô 002
giúp sửa code chọn thư mục bằng chuột và tạo folder và move hình vô đúng folder đã tạo thay vì nhập đường dẫn trong code

Public Sub MoveImages()
 Const strSOURCE_DIR = "d:\Image_Goc\"
 Const strTARGET_DIR = "d:\Image_SoNha\"
  
Dim strSourcePath As String
  Dim strTargetPath As String
  Dim strSubfolder As String
  Dim strFilename As String
  Dim strMessage As String
  Dim strErrors As String
  Dim lngCounter As Long
                

  On Error GoTo ErrHandler
  strFilename = Dir(strSOURCE_DIR & "*.jpg")
    Do While strFilename <> ""
    strSourcePath = strSOURCE_DIR & strFilename
    strSubfolder = strTARGET_DIR & "20200914_13_" & Mid(strFilename, 2, 3) & "_GoVap_D_01" 'D: Duong, H: Hem, 01: Di,02 Ve: tu sua
    strTargetPath = strSubfolder & "\" & strFilename
    
  ' tao folder neu k ton tai
    On Error Resume Next
    MkDir strSubfolder
    If Err.Number <> 0 Then Err.Clear
  
  ' cat qua thu muc moi
    Name strSourcePath As strTargetPath
    
  ' If an error occurred, log it to error list
    If Err.Number <> 0 Then
      If strErrors <> "" Then strErrors = strErrors & ", "
      strErrors = strErrors & strFilename
    Else
      lngCounter = lngCounter + 1
    End If
    
  ' Move onto next jpg file
    On Error GoTo ErrHandler
    strFilename = Dir()
  Loop
  
' Notify user of results, including any errors
  strMessage = "Transfer of " & lngCounter & " files was completed."
  If strErrors <> "" Then
    strMessage = strMessage & vbCrLf & vbCrLf
    strMessage = strMessage & "These files were unsuccessful:"
    strMessage = strMessage & vbCrLf & strErrors
  End If
  MsgBox strMessage, vbInformation
  Exit Sub
  
ErrHandler:
  MsgBox Err.Description, vbExclamation
End Sub