フォルダーを作成して移動する

Option Explicit
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