Excel VBA ファイル操作

Option Explicit

Sub ファイル名変更コピー()

    Dim ファイル名 As String
    Dim 出力フォルダパス As String
    Dim 出力ファイル名 As String
    Dim 出力件数 As Integer
    Dim 開始日時 As Variant
    Dim 終了日時 As Variant

    開始日時 = Now
    ファイル名 = Trim(Range("B4").Value) & Trim(Range("B5").Value)
    出力フォルダパス = Trim(Range("C4").Value)

    If 出力フォルダパス = "" Then
        出力フォルダパス = Trim(Range("B4").Value)
    End If

    出力件数 = 0
    Do
        出力件数 = 出力件数 + 1

        出力ファイル名 = Range("C5").Cells(出力件数, 1)

        If 出力ファイル名 = "" Then Exit Do 'ファイル名が無いところで終わる。

        出力ファイル名 = 出力フォルダパス & 出力ファイル名

        FileCopy ファイル名, 出力ファイル名
    Loop

    終了日時 = Now
    MsgBox "処理時間は、" _
    & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub

Option Explicit

Sub 別のフォルダにそのままコピー()

    Dim 既存フォルダパス As String
    Dim コピー先フォルダパス As String
    Dim 既存ファイル名 As String
    Dim 出力ファイル名 As String
    Dim 出力件数 As Integer
    Dim 開始日時 As Variant
    Dim 終了日時 As Variant

    開始日時 = Now
    既存フォルダパス = Trim(Range("B4").Value)

    If Right(既存フォルダパス, 1) = "\" Then
      既存フォルダパス = Left(既存フォルダパス, Len(既存フォルダパス) - 1)
    End If

    コピー先フォルダパス = Trim(Range("C4").Value)

    If コピー先フォルダパス = "" Then
      MsgBox "コピー先が指定されていません!"
      Exit Sub
    ElseIf Right(コピー先フォルダパス, 1) = "\" Then
      コピー先フォルダパス = Left(コピー先フォルダパス, Len(コピー先フォルダパス) - 1)
    End If

    出力件数 = 0

    Do
        出力件数 = 出力件数 + 1

        既存ファイル名 = Range("B5").Cells(出力件数, 1).Value

        If 既存ファイル名 = "" Then Exit Do 'ファイル名が無いところで終わる。

        出力ファイル名 = コピー先フォルダパス & "\" & 既存ファイル名 'フルパスにする
        既存ファイル名 = 既存フォルダパス & "\" & 既存ファイル名     'フルパスにする

        FileCopy 既存ファイル名, 出力ファイル名
    Loop

    終了日時 = Now
    MsgBox "ファイル数 " & Str(出力件数) & " をコピーしました。" & vbNewLine _
    & "処理時間は、" _
    & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub

Option Explicit

'機能：指定フォルダの全ての下位構成の指定拡張子のファイルを拡張子を変更してコピーする

Dim ファイル_システム_オブジェクト As Object
Dim フォルダ_オブジェクト As Object

Dim サブフォルダ As Variant
Dim ファイル As Variant

Dim フォルダパス As String
Dim ファイル名 As String
Dim 変更前拡張子 As String
Dim 変更後拡張子 As String
Dim 処理フォルダ As String
Dim 拡張子 As String
Dim ファイルフルパス As String

Dim 開始秒 As Single
Dim 開始日時 As Variant
Dim 終了日時 As Variant


Sub 処理を起動()

    開始日時 = Now                ' 開始時刻を変数に格納します。

    ThisWorkbook.Worksheets("Sheet1").Activate
    フォルダパス = Range("B5").Value
    変更前拡張子 = Range("B6").Value
    変更後拡張子 = Range("B7").Value
    
    Set ファイル_システム_オブジェクト = CreateObject("Scripting.FileSystemObject")
    Call フォルダを次々調べて拡張子を変更コピー(ファイル_システム_オブジェクト.getfolder(フォルダパス))

    終了日時 = Now
    MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _
    & Format(終了日時 - 開始日時, "nn分ss秒") & " でした。"

End Sub


Private Sub フォルダを次々調べて拡張子を変更コピー(Folder)
    For Each サブフォルダ In Folder.SubFolders
        処理フォルダ = サブフォルダ.Path
        
        Set フォルダ_オブジェクト = ファイル_システム_オブジェクト.getfolder(処理フォルダ)
        For Each ファイル In フォルダ_オブジェクト.Files
            ファイル名 = ファイル.Name
            拡張子 = ファイル_システム_オブジェクト.GetExtensionName(ファイル名)
            ファイルフルパス = ファイル.Path

            If 拡張子 = 変更前拡張子 Then
                FileCopy ファイルフルパス _
                , Left(ファイルフルパス, Len(ファイルフルパス) - 3) & 変更後拡張子
            End If
        Next
        
        Call フォルダを次々調べて拡張子を変更コピー(サブフォルダ)
    Next
End Sub

Sub フォルダをコピー()
    Dim ファイルシステムオブジェクト As Object           ' FileSystemObject
    Dim コピー元フォルダ As String
    Dim コピー先フォルダ As String
    Dim 現在のパス As String

    Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
    現在のパス = ThisWorkbook.Path

    コピー元フォルダ = 現在のパス & "\元フォルダ名"             ' 元フォルダ(配下の全サブフォルダ)
    コピー先フォルダ = 現在のパス & "\先フォルダ名"             ' 先フォルダ

    ' FSOによるフォルダコピー
    ファイルシステムオブジェクト.CopyFolder コピー元フォルダ, コピー先フォルダ, True

    '同じ名前のファイルが「コピー先」のフォルダ内に既にある場合、
    '「上書きするかどうか」に真 (True) を指定していると、既存ファイルは上書きされます。

    Set ファイルシステムオブジェクト = Nothing

End Sub

Sub フォルダを削除()
    Dim ファイルシステムオブジェクト As Object           ' FileSystemObject
    Dim 削除フォルダ名 As String
    Dim 削除フォルダ As String
    Dim 現在のパス As String
    Dim カウンタ As Integer

    Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
    現在のパス = ThisWorkbook.Path
   Worksheets("Sheet1").Activate
   削除フォルダ名 = Range("A2").Value
   カウンタ = 1
   
   Do While 削除フォルダ名 <> ""
   
      削除フォルダ = 現在のパス & "\" & 削除フォルダ名
      
      ' FSOによるフォルダ削除
      On Error Resume Next
      ファイルシステムオブジェクト.DeleteFolder 削除フォルダ, False
      'Trueを指定すると読み取り専用ファイルも削除されます。省略するとFalseとみなされます。

      カウンタ = カウンタ + 1
      削除フォルダ名 = Range("A2").Cells(カウンタ, 1).Value
   Loop
   
   Set ファイルシステムオブジェクト = Nothing
   MsgBox "フォルダ削除を終わりました。"

End Sub

Sub フォルダ作成()
   Dim 現在のパス As String
   Dim フォルダ名 As String
   Dim 処理行 As Integer
   Dim 最終行 As Integer
   
   ThisWorkbook.Worksheets("管理シート").Activate
   現在のパス = ThisWorkbook.Path
   
   最終行 = Cells(ActiveSheet.Rows.Count, 2).End(xlUp).Row
   For 処理行 = 11 To 最終行
      フォルダ名 = 現在のパス & "\" & Range("B1").Cells(処理行, 1).Value
      If Dir(フォルダ名, vbDirectory) = "" Then 'この名前のフォルダが存在しなければ
         MkDir フォルダ名
      End If
   Next 処理行
End Sub

Option Explicit

'02：2012/03/23：カウンタを追加

   Dim 旧ファイル名 As String
   Dim 新ファイル名 As String
   Dim 最終行 As Integer
   Dim 処理行 As Integer
   Dim 現在のパス As String
   Dim カウンタ As Integer
   

Sub ファイル名変更()

   ThisWorkbook.Worksheets("Sheet1").Activate
   現在のパス = ThisWorkbook.Path
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
   カウンタ = 0
   
   For 処理行 = 2 To 最終行
   
      旧ファイル名 = 現在のパス & "\" & Trim(Range("A1").Cells(処理行, 1).Value)
      新ファイル名 = 現在のパス & "\" & Trim(Range("B1").Cells(処理行, 1).Value)
      
      If Dir(新ファイル名) = "" _
      And Dir(旧ファイル名) <> "" Then '新ファイル名が存在せず、旧ファイル名が存在する場合
         Name 旧ファイル名 As 新ファイル名
         カウンタ = カウンタ + 1
      End If
   
   Next 処理行
   
   MsgBox "指定ファイル数 " & CStr(最終行 - 1) & " 中、" _
   & CStr(カウンタ) & " 件のファイル名を、変更しました。"

End Sub

Option Explicit

'00：2022/10/28：作成

Dim 開始日時 As Variant
Dim 終了日時 As Variant
Dim ファイル名辞書  As Object               ' Scripting.Dictionary オブジェクト
Dim ファイルシステムオブジェクト As Object          ' FileSystemObject

Sub リストに無いファイルを移動()

   開始日時 = Now                                      ' 開始時刻を変数に格納
   
   Set ファイル名辞書 = CreateObject("Scripting.Dictionary")  '★連想配列の定義
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
      
   Call ファイル名読込
   Call ファイル移動

   Set ファイルシステムオブジェクト = Nothing
   Set ファイル名辞書 = Nothing

   終了日時 = Now
   MsgBox "処理が終了しました。" & Chr(13) & _
   "処理時間は、" & Format(終了日時 - 開始日時, "nn分ss秒") & " でした。", vbOKOnly

End Sub


Private Sub ファイル名読込()
   'このブックと同じフォルダの TXT ファイルを読む

   Dim 入力ファイル名 As String
   Dim 入力テキストストリームオブジェクト As Object    ' TextStream
   Dim 処理行カウンタ As Long
   Dim 既存ファイル名 As String
   
   '入力ファイルは決め打ち
   入力ファイル名 = ThisWorkbook.Path & "\★FilesVBS.txt"
   
   '********************************
   'ファイルのオープン。
   処理行カウンタ = 0
   
   ' 指定ファイルをOPEN(入力モード)
'   https://msdn.microsoft.com/ja-jp/library/cc428044.aspx
   Set 入力テキストストリームオブジェクト = _
   ファイルシステムオブジェクト.OpenTextFile(入力ファイル名, 1, , False)

   '************* テキストの内容をファイル名辞書に登録 ***********
   Do Until 入力テキストストリームオブジェクト.AtEndOfStream
   
      ' レコードの読み込み
      既存ファイル名 = 入力テキストストリームオブジェクト.ReadLine
      
      If Trim(既存ファイル名) <> "" Then
      'データが有る行のみを対象とする
      
         処理行カウンタ = 処理行カウンタ + 1
         
         If (処理行カウンタ Mod 1000) = 0 Then
            Application.StatusBar = 処理行カウンタ & " 行目を読込み"
         End If
         
         Debug.Print 既存ファイル名
         
         If ファイル名辞書.Exists(既存ファイル名) = False Then
            ファイル名辞書(既存ファイル名) = "残す"
         End If

      End If

      ' 最終行まで繰り返す
   Loop
   
   '**************終了処理*********************
   Application.StatusBar = 処理行カウンタ & " 最終行まで読込み完了"
   
   ' 指定ファイルをCLOSE
   入力テキストストリームオブジェクト.Close
   Set 入力テキストストリームオブジェクト = Nothing

End Sub


Private Sub ファイル移動()

   Dim 移動元フォルダ As String
   Dim 移動先フォルダ As String
   Dim ファイルオブジェクト As Object
   Dim ファイル名 As String
   
   移動元フォルダ = ThisWorkbook.Sheets("Sheet1").Range("B3").Value
   移動先フォルダ = ThisWorkbook.Sheets("Sheet1").Range("B4").Value
   移動先フォルダ = 移動先フォルダ & "\"

   '上で指定したフォルダ内の、拡張子 jpg を検索
    For Each ファイルオブジェクト In ファイルシステムオブジェクト.GetFolder(移動元フォルダ).Files

      If ファイルシステムオブジェクト.GetExtensionName(ファイルオブジェクト.Name) = "jpg" Then

         ファイル名 = ファイルオブジェクト.Name

         If ファイル名辞書.Exists(ファイル名) = False Then
            'ファイル一覧に存在しない場合は、ファイルを移動
            '移動には VBA の FileCopy を使わずに、ファイルシステムオブジェクトの MoveFile を使う
            ファイルシステムオブジェクト.MoveFile _
            移動元フォルダ & "\" & ファイル名, 移動先フォルダ

         End If
      End If
   Next ファイルオブジェクト
   
   Set ファイルオブジェクト = Nothing

End Sub

Option Explicit

'00：2024/02/16：試作
'01：2024/02/17：作成

Sub ファイル移動()
   Dim 開始時刻 As Variant
   Dim 終了時刻 As Variant

   Dim 移動元フォルダ As String
   Dim 移動先フォルダ As String
   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim ファイルオブジェクト As Object
   Dim ファイル名 As String
   Dim 画像の高さ As Integer
   Dim 移動ファイル数 As Integer
   Dim JPGファイル数 As Long
   
   Dim jpgImg As New ImageFile
   
   開始時刻 = Now()
      
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
      
   JPGファイル数 = 0
   移動ファイル数 = 0
   移動元フォルダ = ThisWorkbook.Path
   画像の高さ = Worksheets("Sheet1").Range("B4").Value
   移動先フォルダ = Worksheets("Sheet1").Range("B5").Value
   If Right(移動先フォルダ, 1) <> "\" Then
      移動先フォルダ = 移動先フォルダ & "\"
   End If

   '上で指定したフォルダ内の、拡張子 jpg を検索
   For Each ファイルオブジェクト In ファイルシステムオブジェクト.GetFolder(移動元フォルダ).Files

      If LCase(ファイルシステムオブジェクト.GetExtensionName(ファイルオブジェクト.Name)) = "jpg" Then
         JPGファイル数 = JPGファイル数 + 1
         ファイル名 = ファイルオブジェクト.Name
         jpgImg.LoadFile 移動元フォルダ & "\" & ファイル名
'         Debug.Print "JPG画像の高さ:" & jpgImg.Height
         'Stop
         If jpgImg.Height < 画像の高さ Then
   
            '移動には VBA の FileCopy を使わずに、ファイルシステムオブジェクトの MoveFile を使う
'            Stop
            ファイルシステムオブジェクト.MoveFile _
            移動元フォルダ & "\" & ファイル名, 移動先フォルダ
            移動ファイル数 = 移動ファイル数 + 1
         End If
      End If
   Next ファイルオブジェクト
   
   Set jpgImg = Nothing
   Set ファイルオブジェクト = Nothing
   Set ファイルシステムオブジェクト = Nothing
   
   終了時刻 = Now()
   MsgBox "処理が終了しました。" & Chr(13) & _
   "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。" & Chr(13) & _
   JPGファイル数 & " 点の JPG ファイル中の" & Chr(13) & _
   移動ファイル数 & " 点のファイルを移動しました！", vbOKOnly
   
End Sub

Option Explicit
Option Base 1

Sub 複数ブックのシートを1つのブックにコピーする()

   Dim 対象シート As Worksheet
   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim フォルダ As Object
   Dim ファイル As Object
   Dim 開始日時 As Variant
   Dim 終了日時 As Variant
   Dim 処理Book As Workbook
   Dim ファイル名 As String
   Dim ワークブック As Workbook
   Dim シート数 As Integer
   Dim ファイル形式 As String
   Dim 出力ブック名 As String


   開始日時 = Now                ' 開始時刻を変数に格納します。

   ThisWorkbook.Worksheets("Sheet1").Activate
   出力ブック名 = Range("A11").Value

   '集約する貼付け先のワークブックを作成
   Set ワークブック = Workbooks.Add

   シート数 = 0

   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")

   Set フォルダ = ファイルシステムオブジェクト.GetFolder(ThisWorkbook.Path)

   '★マクロのExcelの存在するフォルダの全てのファイルを対象
   For Each ファイル In フォルダ.Files
'      Stop
      ファイル名 = ファイル.Path

      If LCase(Mid(ファイル名, InStrRev(ファイル名, ".") + 1, 3)) = "xls" Then

         If Dir(ファイル名) <> ThisWorkbook.Name Then '自分自身(マクロのブック)は対象外

            Set 処理Book = Workbooks.Open(Filename:=ファイル名) 'ブックを開く

             ' 処理Bookのすべてのワークシートを、集約先ブックに登録します。

             For Each 対象シート In 処理Book.Worksheets
               シート数 = シート数 + 1
               If シート数 > 1 Then
                  ワークブック.Worksheets.Add _
                  after:=ワークブック.Worksheets(ワークブック.Worksheets.Count)
               End If

               'シート名をコピー
               ワークブック.Worksheets(ワークブック.Worksheets.Count).Name = 対象シート.Name
               '全てのセルを選択してコピー
               対象シート.Cells.Copy

               '貼付け先シートに貼り付ける
               ワークブック.Worksheets(ワークブック.Worksheets.Count).Activate
               'Paste するためには、Activate が必要
               ワークブック.Worksheets(ワークブック.Worksheets.Count).Paste
               'A1セルを選択して、全セル選択の状態を解除する
               ワークブック.Worksheets(ワークブック.Worksheets.Count).Range("A1").Select

             Next

             処理Book.Application.CutCopyMode = False
             'クリップボードに大きな情報があります。この情報をほかのプログラムに貼り付けられるようにしますか？
             'を表示させない

             処理Book.Close savechanges:=False           '保存せずにブックを閉じる

            Set 処理Book = Nothing

         End If
     End If

   Next '★ファイル

   'シートをコピーしたブックを、名前を付けて保存。拡張子を xls にするために工夫が必要。
'   http://park7.wakwak.com/~efc21/cgi-bin/exqalounge.cgi?print+201001/10010042.txt

   ワークブック.SaveAs _
   Filename:=ThisWorkbook.Path & "\" & 出力ブック名 & Format(Date, "yyyymmdd") & ".xls", _
   FileFormat:=xlWorkbookNormal 'Excel ブック形式

   Set フォルダ = Nothing
   Set ファイルシステムオブジェクト = Nothing
   Set ワークブック = Nothing

   終了日時 = Now
   MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub

Option Explicit
Option Base 1

'01：2019/09/20：作成

   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim フォルダ As Object
   Dim サブフォルダ As Object
   Dim ファイル As Object
   Dim フォルダパス As String
   Dim 旧ファイル名 As String
   Dim 新ファイル名 As String
   Dim 最終行 As Integer
   Dim 現在のパス As String
   Dim カウンタ As Integer
   Dim 拡張子 As String
   Dim 対象拡張子 As String
   Dim ファイル名フルパス As String
   Dim 新ファイル名フルパス As String
   Dim ファイルパス As String
   

Sub ファイル名変更()

'   既存データを削除
   ThisWorkbook.Worksheets("Sheet1").Activate
   対象拡張子 = Range("E1").Value
      
   '既存データの2行目以降を行削除する
   
   'A 列(1列目)を基準に、最終行を求める
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
   If 最終行 > 1 Then
      Rows(2 & ":" & 最終行).Delete Shift:=xlUp
   End If
   
   カウンタ = 0
   
   フォルダパス = ThisWorkbook.Path
'   Stop
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   
   Call フォルダを次々調べてファイル名を変更(ファイルシステムオブジェクト.getfolder(フォルダパス))
   
   MsgBox "更新対象のファイル件数は " & CStr(カウンタ) & " でした。"

End Sub


Private Sub フォルダを次々調べてファイル名を変更(Folder As Object)
   Dim フォルダ_オブジェクト As Object
   Dim ファイル_オブジェクト As Object
   Dim サブフォルダ_オブジェクト As Object
   
   Set フォルダ_オブジェクト = ファイルシステムオブジェクト.getfolder(Folder)

   For Each ファイル_オブジェクト In フォルダ_オブジェクト.Files
   
      旧ファイル名 = ファイル_オブジェクト.Name

      拡張子 = ファイルシステムオブジェクト.GetExtensionName(旧ファイル名)
      ファイルパス = ファイル_オブジェクト.ParentFolder.Path & "/"

      If 拡張子 = 対象拡張子 Then
         
         新ファイル名 = 英数半角(旧ファイル名)

         If 旧ファイル名 <> 新ファイル名 Then
'            Stop
            カウンタ = カウンタ + 1
            Range("A1").Cells(カウンタ + 1, 1).Value = ファイルパス
            
            If Dir(ファイルパス & 新ファイル名) = "" _
            And Dir(ファイルパス & 旧ファイル名) <> "" Then '新ファイル名が存在せず、旧をファイル名が存在する場合
               Debug.Print 旧ファイル名 & vbNewLine & 新ファイル名
               Name ファイルパス & 旧ファイル名 As ファイルパス & 新ファイル名
               Range("B1").Cells(カウンタ + 1, 1).Value = 旧ファイル名
               Range("C1").Cells(カウンタ + 1, 1).Value = 新ファイル名
            Else
               Range("B1").Cells(カウンタ + 1, 1).Value = 旧ファイル名
               Range("C1").Cells(カウンタ + 1, 1).Value = "新ファイル名が既存"
            End If
         End If
      
      End If '対象拡張子
   Next

   'サブフォルダについても同様に行う
   For Each サブフォルダ_オブジェクト In Folder.SubFolders
      Call フォルダを次々調べてファイル名を変更(サブフォルダ_オブジェクト)
   Next
   
End Sub



Function 英数半角(入力文字列 As String) As String

   Dim 結果文字列 As String
   Dim 文字目 As Integer
   Dim 文字 As String

   結果文字列 = ""

   For 文字目 = 1 To Len(入力文字列)
   
       文字 = Mid(入力文字列, 文字目, 1)
          
      If (文字 >= "０" And 文字 <= "９") _
         Or (文字 >= "Ａ" And 文字 <= "Ｚ") _
         Or (文字 >= "ａ" And 文字 <= "ｚ") _
         Or (文字 = "（" Or 文字 = "）") _
         Or (文字 = "　") Or (文字 = "−") Then
            結果文字列 = 結果文字列 & StrConv(文字, vbNarrow)
         Else
            結果文字列 = 結果文字列 & 文字
      End If

   Next 文字目
   
   英数半角 = 結果文字列

End Function