エクセルVBA ファイル移動について お詳しい方 ご教授をお願いします やりたいこと エクセルファイ

エクセルVBA ファイル移動について

お詳しい方　ご教授をお願いします

やりたいこと
エクセルファイルにて
下記のコードにて指定フォルダの指定した拡張子ごとセルC6からリスト化を行う
Sub ファイル取込_Click()

    Dim buf As String, cnt As Long

    Const Path As String = "C:\Sample\"

    buf = Dir(Path & "*.xlsx")

    Do While buf <> ""

 

        cnt = cnt + 1

        Cells(cnt + 5, 3) = buf

        buf = Dir()

    Loop

    buf = Dir(Path & "*.bmp")

    Do While buf <> ""

 

        cnt = cnt + 1

        Cells(cnt + 5, 3) = buf

        buf = Dir()

    Loop

  

    buf = Dir(Path & "*.jpg")

    Do While buf <> ""

 

        cnt = cnt + 1

        Cells(cnt + 5, 3) = buf

        buf = Dir()

    Loop

   

     buf = Dir(Path & "*.pdf")

    Do While buf <> ""

 

        cnt = cnt + 1

        Cells(cnt + 5, 3) = buf

        buf = Dir()

      Loop

   

     buf = Dir(Path & "*.pptx")

    Do While buf <> ""

 

        cnt = cnt + 1

        Cells(cnt + 5, 3) = buf

        buf = Dir()

       

         Loop

   

     buf = Dir(Path & "*.xlsm")

    Do While buf <> ""

 

        cnt = cnt + 1

        Cells(cnt + 5, 3) = buf

        buf = Dir()

       

            Loop

   

     buf = Dir(Path & "*.log")

    Do While buf <> ""

 

        cnt = cnt + 1

        Cells(cnt + 5, 3) = buf

        buf = Dir()

       

                  Loop

   

     buf = Dir(Path & "*.docx")

    Do While buf <> ""

 

        cnt = cnt + 1

        Cells(cnt + 5, 3) = buf

        buf = Dir()

                      Loop

   

     buf = Dir(Path & "*.zip")

    Do While buf <> ""

 

        cnt = cnt + 1

        Cells(cnt + 5, 3) = buf

        buf = Dir()

       Loop

End Sub

その後
C3,C4,C5のセル記載内容を元に名前を付け新規作成するコードを使用
'-----------------------------------------同名フォルダを探し無ければ作成を行う

Dim xFold As String, xPath As String

Range("A1").Activate

Const xParent As String = "C:\Users\PC\Documents\新しいフォルダ\" '保存フォルダ先

xFold = ActiveCell.Offset(2, 2).Value & ActiveCell.Offset(3, 2).Value & ActiveCell.Offset(3, 4).Value  'フォルダの名前設定

xPath = xParent & xFold

If Dir(xPath, vbDirectory) = vbNullString Then

MsgBox xParent & "に" & xFold & "フォルダを作成します。"

MkDir xPath

Else

MsgBox xPath & "は既にあります。"

Exit Sub

End If

困り事
ここまではいけたのですが、
自動で新規作成したフォルダにリスト化した同名ファイルを移動させるのがうまくいきません
フォルダ名を指定しての移動は簡単にできたのですが・・
アドバイスをお願いします

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

• 誤記ありましたフォルダ名の指定はC3,C4,E4です
  申し訳ないです

    補足日時：2019/03/06 12:37

• 

  ご回答いただきありがとうございます
  早速教えていただいたコードを使い一つのプロシージャで完結させるように対応してみたのですが
  buf=.cells(i,3)の所で参照が不正または不完全ですと出てしまいます
  オブジェクトの指定がうまくいっていないということでしょうか？

    補足日時：2019/03/07 09:36

• 

  このように新規フォルダを作成して
  
  その作成したフォルダに指定したファイルを入れようとしたのですが、
  
  以下のようになります
  
  ①フォルダは指定場所に名前付きで保存される
  
  ↓
  
  ②ファイルが新規されたフォルダ内に移動されず、フォルダが作成された場所に
  移動される
  例　サンプルフォルダ
  移動ファイル
  のような感じです。
  ↓
  ③移動用ファイルがフォルダ名の名前が追加される
  
  例　フォルダ名移動ファイル名.pptx
  
  フォルダ新規作成コードに
  
  Sub 登録_Click()
  
  Dim dat  As String
  
  Dim buf As String, cnt As Long
  
  Const Path As String = "C:\Sample\"
  
  と宣言を追加
  
  そのまま
  
  End ifまでコードを転用し
  
  教えて頂いたコードを追加

    補足日時：2019/03/07 17:02

No.3 ベストアンサー 回答者： しん14 回答日時： 2019/03/07 18:37

何度も回答してしまい申し訳ありません。

多分以下でいけます！

Do While Cells(i, 3) <> ""
　　buf = Cells(i, 3)
　　Name Path & buf As xPath & "\" & buf
　　'コピーする場合は
　　'FileCopy Path & buf, xPath & "\" & buf
　　i = i + 1
Loop

タイプミスとスラッシュ漏れと、結構初歩的なミスばかりですみません。
これでお願いします。

この回答へのお礼

対応できました　　貴重なアドバイスいだだきありがとうございました

お礼日時：2019/03/07 21:33

No.2 回答者： しん14 回答日時： 2019/03/07 13:55

ごめんなさい、私のミスタイプです。

buf = .Cells〜 ×
buf = Cells〜 ○

「.」が不要ですね。
この部分を修正して、もう一度試してみていただけますか？

No.1 回答者： しん14 回答日時： 2019/03/07 00:23

こんばんは

あと一息ですね！

一連の操作を1つのプロシージャ内で完結する、という想定で、
以下のようなコードはいかがですか。

Dim i As Long
i = 6
'cntをもう使用しないのならばiをcntに置き換え、iの宣言は不要

Do While Cells(i, 3) <> ""
　　buf = .Cells(i, 3)
　　Name Path & buf As xPath & buf
　　'コピーする場合は
　　'FileCopy Path & buf, xPath & buf
　　i = i + 1
Loop

xPathを用いた質問本文後半の記述+上記コードを
質問本文前半の最後部に挿入することで、ファイル名のリスト化と
新規フォルダの作成、移動が完結できるのではないでしょうか。

もしそれぞれの操作を別のプロシージャに分割したい、ということであれば
プロシージャの引数にPathやxPath、bufを渡して処理をさせる形で分割すると
よいかと思われます。

参考までにご覧ください。