ファイルの移動をしたい

Question

ファイルの移動をしたいのですができません。
ファイルを1度開き、項番を取得して、その項番フォルダーにファイルを移動させたいのですができません。
また、1度目のLoopではファイル名が取得できているのですが、2度目のLoopに入るとFileが空になってしまいます。

Private Sub CommandButton2_Click()
'Dim fso As FileSystemObject
'Set fso = New FileSystemObject
Set wb = ThisWorkbook
File = Dir(wb.Path & "\エントリーシート*.xlsx")
    Do While File <> ""
        
        '開くExcelファイル
        FilePath = wb.Path & "\エントリーシート\" & File
        Set wbEntry = Workbooks.Open(FilePath)
        Set shEntry = wbEntry.Worksheets(1)
        'エントリーシートの項番
        Entrynum = Format(shEntry.Range("B10"), "000")
        Workbooks(File).Close savechanges:=False
        
        Folder = wb.Path & "\エントリーシート\" & Entrynum
        If Dir(Folder, vbDirectory) <> "" Then
            Name FilePath As Folder & File
            'Call fso.MoveFile(FilePath, Folder & File)
        End If
        File = Dir()
    Loop

End Sub

Answer 1

Dir()をループで使用した場合、前回の状況を利用した動作になります。
そこでファイルを移動しているので、ズレているわけです。
ループ自体をFileSystemObjectを使用したものに置き換えるのが良いかと思います。

Comments

[TanakaHiroaki]

ループ処理中のファイルリネームや移動は難しいですね。
こういった場合、面倒でも条件に合致するファイルを一旦配列に入れてから処理するようにしています。

[Naoko_Coco]

それはどのようにしたら良いのでしょうか？
コメントアウトにしているんですが、

Dim fso As FileSystemObject
Set fso = New FileSystemObject
File = Dir(wb.Path & "\エントリーシート*.xlsx")
Do While File <> ""

'開くExcelファイル
FilePath = wb.Path & "\エントリーシート\" & File
Set wbEntry = Workbooks.Open(FilePath)
Set shEntry = wbEntry.Worksheets(1)
'エントリーシートの項番
Entrynum = Format(shEntry.Range("B10"), "000")
Workbooks(File).Close savechanges:=False

Folder = wb.Path & "\エントリーシート\" & Entrynum
If Dir(Folder, vbDirectory) <> "" Then
fso.MoveFile FilePath, Folder & File
End If
File = Dir()
Loop
こちらで試しても移動ができません。
更に、なぜかBookを閉じる際にファイル名が変数Entrynumがプラスされた状態で上書き保存がされてしまっています。

[sazi]

Dir()を使用しないという事です。
以下参考。
http://officetanaka.net/excel/vba/filesystemobject/sample07.htm

[Naoko_Coco]

とりあえずまんまを書いてみました。
Dim FSO As Object, f As Variant, BaseNames() As String, cnt As Long, i As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
Set wb = ThisWorkbook
FilePath = wb.Path & "\エントリーシート\"
ReDim BaseNames(FSO.GetFolder(FilePath).Files.Count)
For Each f In FSO.GetFolder(FilePath).Files
If LCase(FSO.GetExtensionName(f.Name)) = "xlsx" Then
cnt = cnt + 1
BaseNames(cnt) = FSO.GetBaseName(f.Name)
End If
Next f
If cnt = 0 Then
MsgBox "xlsxファイルはありません", vbExclamation
Else
For i = 1 To cnt
FilePath = FilePath & "\" & BaseNames(i)
Set wbEntry = Workbooks.Open(FilePath)
Set shEntry = wbEntry.Worksheets(1)
'エントリーシートの項番
Entrynum = Format(shEntry.Range("B10"), "000")
' Workbooks.Close savechanges:=False

Folder = wb.Path & "\エントリーシート\" & Entrynum
If Dir(Folder, vbDirectory) <> "" Then
'Name FilePath As Folder & File
FSO.MoveFile FilePath, Folder & BaseNames(i)
End If

Next i
End If
するとMoveFileのときにファイルが見つかりませんになります。

[sazi]

Dir()は使わないでと言っているんですが。

[TanakaHiroaki]

いろいろ気になりますが、配列は　ReDim Preserve　を使うほうが良いです。
https://www.relief.jp/docs/excel-vba-what-is-redim-preserve.html

[Naoko_Coco]

できました～～～～！！

[TanakaHiroaki]

そうですか。学習能力高いですね。

[Naoko_Coco]

できてませんでした。。。

[TanakaHiroaki]

FSO.MoveFile FilePath, Folder & ”\” & BaseNames(i)
でどうでしょうか。

[Naoko_Coco]

できました～

[Naoko_Coco]

Debugで見たら拡張子がなかったためできなかったみたいです。

Answer 2

素晴らしいですね。
配列を1から使用される場合、先頭に
Option Base 1
をつけておくとなお良いです。

Comments

[Naoko_Coco]

ありがとうございます。
Option Base 1
これはどういった意味なのでしょうか？

[TanakaHiroaki]

VBAの配列はから始まるのが基本なので、１から始まる場合 Option Base 1 が無難です。
言い換えると、BaseNames(０)を使用できないように明示するだけの処理です。

[Naoko_Coco]

そうなんだ！配列は常に0からだと思ってて、明示的にするときはarr（1）とか指定するもんだと思ってました。
なるほどです！
ありがとうございます。

[TanakaHiroaki]

Option Base 1有無の違いは、配列の添え字の最小値や最大値を確認すると良くわかると思います。
Debug.Print LBound(BaseNames) '最小値
Debug.Print UBound(BaseNames) '最大値

Answer 3

saziさんのご意見を元に・・・Dirはフォルダー調べる際に使っちゃってますが。。。

Private Sub CommandButton2_Click()
Dim FSO As Object, f As Variant, BaseNames() As String, cnt As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
Set wb = ThisWorkbook
FilePath = wb.Path & "\エントリーシート\"
ReDim BaseNames(FSO.GetFolder(FilePath).Files.Count)
For Each f In FSO.GetFolder(FilePath).Files
    If LCase(FSO.GetExtensionName(f.Name)) = "xlsx" Then
        cnt = cnt + 1
        BaseNames(cnt) = FSO.GetBaseName(f.Name)
    End If
Next f
If cnt = 0 Then
    MsgBox "ファイルはありません", vbExclamation
Else
    For i = 1 To cnt
        File = FilePath & BaseNames(i)
        Debug.Print BaseNames(i)
        Set wbEntry = Workbooks.Open(File)
        Set shEntry = wbEntry.Worksheets(1)
        'エントリーシートの項番
        Entrynum = Format(shEntry.Range("B10"), "000")
'        Workbooks.Close savechanges:=False
        ActiveWorkbook.Saved = True
        ActiveWorkbook.Close

        Folder = wb.Path & "\エントリーシート\" & Entrynum
        If Dir(Folder, vbDirectory) <> "" Then
            'Name FilePath As Folder & File
            Debug.Print FilePath
            Debug.Print Folder & "\" & BaseNames(i)
            FSO.MoveFile File & ".xlsx", Folder & "\" & BaseNames(i) & ".xlsx"
        End If
        
        
    Next i
End If

Comments

[TanakaHiroaki]

素晴らしいですね。
配列を1から使用される場合、先頭に
Option Base 1
をつけておくとなお良いです。