フォルダ フォルダ内の全てのファイル移動(同名存在削除)
※より実装に近く表示させる為、コードの改行を避けています。スマホ等で閲覧される際は向きを変えてご覧ください。
※実装するバージョンによってはバージョンアップの仕様により動作しないコードもあります。実装には動作確認の上ご使用下さい。
Sub FolderInFileMove() '*********************************************** 'フォルダ内の全てのファイル移動(同名存在削除) '*********************************************** '移動先に同じ名前のファイルが存在する場合は削除 '手段は他にもあります。 Dim buf As String Dim tgtPath As String Dim OutPath As String Dim DefaultFolderName As String Dim NewFolderName As String Dim ExtensionName As String ExtensionName = "htm*" '指定してください" DefaultFolderName = "元フォルダ" '移動元フォルダ名 NewFolderName = "先フォルダ" '移動先フォルダ名 tgtPath = ThisWorkbook.Path & "\" & DefaultFolderName OutPath = ThisWorkbook.Path & "\" & NewFolderName buf = Dir(tgtPath & "\*." & ExtensionName) Do Until buf = Empty 'FileCopyの場合は同名ファイルでもコピー(上書き)します。 FileCopy tgtPath & "\" & buf, OutPath & "\" & buf buf = Dir() Loop 'ファイルの存在確認 If Dir(tgtPath & "\*." & ExtensionName) <> "" Then '元のファイルを削除します Kill tgtPath & "\*." & ExtensionName End If End Sub Sub FolderInFileMove2() '*********************************************** 'フォルダ内の全てのファイル移動(同名存在削除) '*********************************************** '移動先に同じ名前のファイルが存在する場合は削除 '手段は他にもあります。 Dim buf As String Dim tgtPath As String Dim OutPath As String Dim DefaultFolderName As String Dim NewFolderName As String Dim ExtensionName As String ExtensionName = "htm*" '指定してください" DefaultFolderName = "元フォルダ" '移動元フォルダ名 NewFolderName = "先フォルダ" '移動先フォルダ名 tgtPath = ThisWorkbook.Path & "\" & DefaultFolderName OutPath = ThisWorkbook.Path & "\" & NewFolderName buf = Dir(tgtPath & "\*." & ExtensionName) Do While buf <> "" 'FileCopyの場合は同名ファイルでもコピー(上書き)します。 FileCopy tgtPath & "\" & buf, OutPath & "\" & buf buf = Dir() Loop 'ファイルの存在確認 If Dir(tgtPath & "\*." & ExtensionName) <> "" Then '元のファイルを削除します Kill tgtPath & "\*." & ExtensionName End If End Sub |