◎Aフォルダーの中ファイル名を取込み、Bフォルダーに移動する。

Sub 練習用フォルダ()
 
    Dim Path As String '作成予定フォルダの上位パス
    Path = Range("A2").Value
   
    Dim i As Long
    For i = 2 To Range("D2").End(xlDown).Row
   
        Dim FolderName As String '作成するフォルダ名
        FolderName = Cells(i, 4).Value
       
        Dim NewDirPath As String '作成予定のフォルダパス
        NewDirPath = Path & "\" & FolderName
       
        '作成予定フォルダと同名のフォルダの存在有無を確認
        If Dir(NewDirPath, vbDirectory) = "" Then
            MkDir Path & "\" & FolderName
        End If
   
    Next i
   
    MsgBox "終了しました。"
 
End Sub

    Next i
   
    MsgBox "終了しました。"
 
End Sub
---------------------------------------------------------------------

Sub Folder_DirSample()  '検索

  Dim A, folSample As String
 
'--------------------------------
    Dim Path As String '作成予定フォルダの上位パス
'    Path = Range("A2").Value
   
    Dim i As Long
    For i = 2 To Range("B2").End(xlDown).Row
   
        Dim FolderName As String '作成するフォルダ名
                    
        FolderName = Cells(i, 2).Value    'セルから取る
'---------------------------------------------

 移動元 = Range("A2").Value 'D:\Data
 移動先 = Range("A3").Value 'D:\Data\移動先

  '検索対象のフォルダ名
 ' A = "20190001"
  A = FolderName

移動フォルダ = 移動先 & "\" & FolderName
移動先フォルダ = 移動元 & "\" & FolderName & "*"
  'フォルダ名の取得
'  folSample = Dir(ThisWorkbook.Path & "\" & folname, vbDirectory)
    folSample = Dir(移動元 & "\" & A, vbDirectory)

  'フォルダの存在有無を判定
  If Len(folSample) <> 0 Then
      '「有り」の結果をメッセージボックスで表示
      MsgBox (folSample & "の存在を確認しました。"), vbInformation
     
     
 Dim fso As New Scripting.FileSystemObject
  Dim sourceFolder  As String
  Dim destinationFolder As String
 
'  sourceFolder = "K:\Excel2016VBA_*"
  sourceFolder = 移動先フォルダ

'  destinationFolder = "K:\ExcelVBA_Test\backup\"
  destinationFolder = 移動フォルダ

  fso.MoveFolder sourceFolder, destinationFolder
  Set fso = Nothing

     
'         fso.MoveFolder Source:=移動フォルダ, Destination:=移動先フォルダ      
   
    Else
          MsgBox (folname & "は存在しません"), vbCritical
           
    End If

    Next i
   
    MsgBox "終了しました。"
 
End Sub

---------------------------------------------------------------------

Sub フォルダ移動()
Dim fso As New Scripting.FileSystemObject
Dim i As Long
Dim 移動元 As String
Dim 移動先 As String
Dim 移動元フォルダ As String
Dim 移動先フォルダ As String
移動元 = Range("A2").Value 'D:\Data
移動先 = Range("A3").Value 'D:\Data\ 移動先
If Dir(移動元, vbDirectory) = "" Then
MsgBox ("移動元フォルダ<" & 移動元 & ">が存在しません")
Exit Sub
End If
If Dir(移動先, vbDirectory) = "" Then
MsgBox ("移動先フォルダ<" & 移動先 & ">が存在しません")
Exit Sub
End If
For i = 2 To Range("B2").End(xlDown).Row
Dim FolderName As String
FolderName = Cells(i, 2).Value
移動元フォルダ = 移動元 & "\" & FolderName & "*"
移動先フォルダ = 移動先 & "\" & FolderName
If Dir(移動元フォルダ, vbDirectory) <> "" Then
If Dir(移動先フォルダ, vbDirectory) = "" Then
MkDir 移動先フォルダ
End If
fso.MoveFolder 移動元フォルダ, 移動先フォルダ
End If
Next i
MsgBox "終了しました"
End Sub