再度です。Excelvbaで条件でフォルダーをフォルダーに移動

先ほど質問して一度は出来ましたが、2度目出来なくなりました。
https://oshiete.goo.ne.jp/mypage/history/question/

数百あるフォルダーがあります。
20190802-1、20190802-2,20190802-3,20190802-終
頭8桁が変更します。
枝番を除外して頭8桁のフォルダー名を作成し、同じ8桁のフォルダー作成したフォルダーに移動させたいのですができません。
'-------------------------------------汚いコードですが
Dim A, folSample,sourceFolder,destinationFolder As String
Dim Path As String
Dim fso As New Scripting.FileSystemObject
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 = FolderName

移動フォルダ= 移動先 & "\" & FolderName
移動先フォルダ= 移動元 & "\" & FolderName & "*"
folSample = Dir(移動元 & "\" & A, vbDirectory)
If Len(folSample) <> 0 Then
MsgBox (folSample & "の存在を確認しました"), vbInformation

sourceFolder = 移動先フォルダ
destinationFolder = 移動フォルダ
fso.MoveFolder sourceFolder, destinationFolder
Set fso = Nothing

Else
MsgBox (folname & "は存在しません"), vbCritical
End If
Next i
MsgBox "終了しました"

End Sub

エラーはでません。フォルダーが存在するのに無いとなります。
宜しくお願い申し上げます。

質問者からの補足コメント

• tatu99様
  はいそうです。
  D列にフォルダー名を書き出し
  C列にフォルダーをD列から取り出し(関数が入っています。LEFT(D2,8))
  B列に(C列の重複を除いたもの)なければフォルダー作成
  一度できたのですが、最終報がなければ移動しないと言うのを追加しようと試行錯誤している
  うちにおかしくなりました。
  宜しくお願い申しあげます。

  
    補足日時：2019/08/11 16:58

No.1 回答者： tatsu99 回答日時： 2019/08/11 15:22

もし、

D:\goo\dataの下に以下のフォルダがあるとし、
20190802-1
20190802-2
20190803-1
20190803-2
D:\goo\data\移動先　に上の４つのフォルダを移動させたいとき

シートのB列はどのように記述されているのでしょうか。
添付図の左側（赤線で囲んだところ）ですか、それとも、右側（青線で囲んだところ）ですか？

この回答へのお礼

ありがとうございました。
できました。

お礼日時：2020/03/11 23:23

No.2 回答者： tatsu99 回答日時： 2019/08/11 15:38

質問１：

移動元のフォルダに以下のフォルダがあるとして
20190802-1
20190802-2
20190803-1
20190803-2
移動先に移動すると

移動先に
20190802のフォルダが作成され、その下に下記のフォルダが作られる
20190802-1
20190802-2　

20190803のフォルダが作成され、その下に下記のフォルダが作られる
20190803-1
20190803-2
となれば、よいのでしょうか。

質問２：
そうすると、
＞先ほど質問して一度は出来ましたが、2度目出来なくなりました。
ということですが、移動元のフォルダはなくなるので、2度目はできなくなるは当たり前かと思いますが・・・

この回答へのお礼

ありがとうございました。
出来上がりました。

お礼日時：2020/03/11 23:24

No.3 ベストアンサー 回答者： tatsu99 回答日時： 2019/08/11 19:03

No2です。

No2の返信がないので、こちらで仮定して、マクロを作成します。
①移動元に20190802*に該当するフォルダがない場合は、そのフォルダの移動はエラー表示せずにスキップする。
②移動先に20190802に該当するフォルダがない場合は、そのフォルダを作成する。
③移動元＝20190802*　、　移動先＝20190802　としてフォルダの移動を行う。
上記条件で作りました。
尚、1回実行した後、そのままのシートの状態で、もう一度、実行すると、移動元のフォルダがないので、処理がスキップされ、「終了しました」だけが表示されます。
-----------------------------------
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

この回答へのお礼

tatu99様

ありがとうございます。
これです。

綺麗に書いて頂いてありがとうございます。

お礼日時：2019/08/11 19:12