VBAにて複数ファイルを振り分け

Question

ネットワークドライブ上にあるファイルを日付別にフォルダ作成し、振り分けしたいです。
以下、やりたいこと詳細です。
1.エクセルシートに移動前・移動後ディレクトリ、作成するフォルダ名のマスタがあるのでそれから情報を取得
2.各移動先ディレクトリに新規フォルダの作成
3.2で作成したフォルダにxlsxファイルとcsvファイルを移動
(マスタシートB列に移動前Dir,C列に移動後Dir,D列に作成するファルダ名としています)

こんな感じのイメージです。
Aフォルダ
　┣oldフォルダ
　┣ファイルA.xlsx
　┣ファイルB.xlsx
　┣ファイルC.xlsx
　┗ファイルD.csv
　↓
Aフォルダ
　┣oldフォルダ
　　　┗新規フォルダ
　　　　┣ファイルA.xlsx
　　　　┣ファイルB.xlsx
　　　　┣ファイルC.xlsx
　　　　┗ファイルD.csv

以下、コードですがこれを実行すると「FSO.MOVEFILE consSOUR, consDEST」の部分でファイルが見つかりませんとエラーになってしまいます。
・FileSystemObjectの参照設定は行っております。
・csvとxlsxを両方指定する方法が分からなかったので一旦xlsxの移動のコードのみです。

Sub test()

'FSO
Dim FSO As FileSystemObject
 Set FSO = New FileSystemObject
 Set FSO = CreateObject("Scripting.FileSystemObject")

'************************************フォルダ作成****************************************

'Dir情報取得
Dim sour, dest, consSOUR, consDEST As Long
Dim FolderName, Path, TargetPath As String

'作成するフォルダ名を指定
 FolderName = Cells(7, 4).Value

'移動先パス指定
Dim i As Long

For i = 7 To Range("C7").End(xlDown).Row
Path = Cells(i, 3).Value
TargetPath = Path & "\" & FolderName

If (FSO.FolderExists(TargetPath) = False) Then
 '//フォルダが存在しない
 FSO.createFolder (TargetPath)
Else
 '//フォルダが存在する
 GoTo continue
End If

continue:
 Next

'************************************ファイル移動****************************************

Dim j
For j = 7 To Cells(Rows.Count, "B").End(xlUp).Row
 sour = Cells(j, 2).Value
 dest = Cells(j, 3).Value
 consSOUR = sour & "\" & "*.xlsx"
 consDEST = dest & "\" & FolderName
 
'FSOによるファイルコピー
 FSO.MOVEFILE consSOUR, consDEST

Next j

'オブジェクトの解放
Set FSO = Nothing

MsgBox "移動完了しました"
End Sub

また、色々調べてみてshellobjを追加してみましたが同じ結果になったので一旦上記のコードからは省いてます。
この際「Windows Script Host Object Model」の参照設定も行いました。

'追加したshellobj
Dim ShellObj
    Set ShellObj = CreateObject("WScript.Shell")
    ShellObj.Run "net use consSOUR, 0, True"

分かる方、ご教示いただければと思います。
宜しくお願い致します。

【追記】
「Debug.Print ; consSOUR」と「Debug.Print ; consDEST」を「FSO.MOVEFILE consSOUR, consDEST」の直前に追加し、内容が以下になります。
\space\kyouyu\各案件フォルダ\【201809分】\①インポート*.xlsx
\space\kyouyu\各案件フォルダ\【201809分】\①インポート\old\0913

また、「fso.FileExists」を以下のような形で追加し確認したところ「consSOUR が存在しません」と表示されました。

If FSO.FileExists(consSOUR) Then
     MsgBox consSOUR & "が存在します"
      If FSO.FileExists(consDEST) Then
         MsgBox consDEST & "が存在します"
  Else
         MsgBox consDEST & "が存在しません"
  End If
  Else
     MsgBox consSOUR & "が存在しません"
  End If

Comments

[退会済みユーザー]

ネットワークドライブとのことなので、パス指定に間違っていないかを確認したいと思います。 FSO.MOVEFILEの直前にDebug.Print consSOURとDebug.Print consDESTで変数の内容を出力して、可能な範囲で追記していただけませんか。あとfso.FileExistsで存在確認をしてどちらが原因でエラーが出ているか教えてください。

[4n5]

ありがとうございます。追記いたしましたのでご確認いただければと思います。

Answer 1

コードをしっかりと読んでいませんでした。
consSOURの方はワイルカード指定で、consDESTはフォルダ指定だったのですね。
無駄な追記をさせて申し訳ございませんでした。

FileSystemObjectのMoveFileメソッドの第二引数「destination」ですが、ここにフォルダを指定する場合は、最後に\記号が必要となります。
（そうしないと拡張子の存在しないファイル名と判別できないですからね）

従って次のように修正してみてください。

 consDEST = dest & "\" & FolderName & "\"

【2018/9/17 2:00:00追記】
実際にネットワーク上においてデバッグしてみました。

Dim sour, dest, consSOUR, consDEST As Long

この構文ですが本当にこう書いてます？
VBAのDimは一度に型指定することは出来ないので、
・sour,dest,consSOURは省略とみなされVariant型
・consDESTだけがLong型
で定義されています。

ファイルパスであるconsDESTがLong型では動かないはずですが、本当はこうではないですか？

Dim sour As String, dest As String, consSOUR As String, consDEST As String
Dim FolderName As String, Path As String, TargetPath As String

'FSOによるファイルコピー

MoveFile使ってますが、移動じゃないんですか？

consSOUR の該当ファイルが0件の場合に「ファイルが見つかりません」が出るようです。

ワイルドカードでファイルが1件以上存在するか確認する方法がfsoには無かったと思うので、下記通りDirを使ってチェックするように直したほうが良いと思います。

    For j = 7 To Cells(Rows.Count, "B").End(xlUp).Row
        sour = Cells(j, 2).Value
        dest = Cells(j, 3).Value
        consSOUR = sour & "\" & "*.txt"
        consDEST = dest & "\" & FolderName & "\"
        
        'FSOによるファイル移動
        If Dir(consSOUR) <> "" Then
            FSO.MOVEFILE consSOUR, consDEST
        Else
            Debug.Print consSOUR & "に該当ファイル無し"
        End If
    Next j

この修正で私の環境では問題なく動きました。一度ご確認ください。

Comments

[4n5]

いえいえ、とんでもございません。
ただいまご指摘内容にて修正いたしましたが、同じく「ファイルが見つかりません」とエラーを吐いてしまいます。
また、ネットワークドライブではなくローカルフォルダ→ローカルフォルダですと問題なく実行できました。
お手数をおかけいたしますが、他に可能性があるところがございましたらご指摘いただければと思います。
何卒宜しくお願い致します。

[退会済みユーザー]

2018/9/17 2:00:00追記しました。エラーが出る移動元フォルダの該当ファイル数が0件ではないかご確認ください。

[4n5]

すいません、返信したと思っておりましたが、文章入力中のままとなっており返信できておりませんでした。。。

ありがとうございます！
すいません、Dim sour......As LongですがStringに変更前のものを記述しておりました。
また、コピーではなく移動でした。ネットからコピペしてそのままでした。
混乱させてしまい申し訳ございません。

ご教示していただいたコードで問題なく動作いたしました。
ありがとうございます。
今回が初めてのマクロだったので分からないことだらけでしたが、心強いご指摘にて無事完成しました。
心よりお礼申し上げます。