Excel VBA ファイル操作

Option Explicit
Option Base 1

Sub ページ歴史取得()

   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim 入力テキストストリームオブジェクト As Object    ' TextStream
   Dim フォルダパス As String
   Dim フォルダ As Object
   Dim ファイル As Object
   Dim ファイル名 As String
   Dim ファイル数 As Integer
   Dim 配列(1, 2) As String
   
   Dim 入力行 As String
   Dim 出力行数 As Integer
   
   Dim 開始時刻 As Variant
   Dim 終了時刻 As Variant

   ChDrive (ThisWorkbook.Path)
   ChDir (ThisWorkbook.Path)
   
    '[ファイルを開く]ダイアログボックスで、ファイルを指定して、パスを取得
    フォルダパス = Application.GetOpenFilename("HTMLファイル,*.html")
   
    '[ファイルを開く]で「キャンセル」した場合は、処理を終了
    If フォルダパス = "False" Then End
    
    開始時刻 = Now                ' 開始時刻を変数に格納します。
   
    'フォルダパスから、後ろのファイル名の部分を削除して、フォルダ・パスに変更
    フォルダパス = Left(フォルダパス, InStrRev(フォルダパス, "\"))

   'ファイルシステム・オブジェクトを使って、フォルダ、ファイルを操作する
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   Set フォルダ = ファイルシステムオブジェクト.GetFolder(フォルダパス)

   '★指定した html の存在するフォルダの全ての html ファイルを対象
   ファイル数 = 0
   出力行数 = 2
   
   ThisWorkbook.Worksheets("Sheet1").Activate
   
   For Each ファイル In フォルダ.Files
   
      ファイル名 = ファイル.Name

      'ファイルの拡張子を調べて、html ファイルのみを、取得対象とする
      If LCase(Mid(ファイル名, InStrRev(ファイル名, ".") + 1, 4)) = "html" Then
      
         'ファイルが、html ファイルだったら
         ファイル数 = ファイル数 + 1
         
         ' 指定ファイルをOPEN(入力モード)
         Set 入力テキストストリームオブジェクト = _
         ファイルシステムオブジェクト.OpenTextFile(ファイル名, 1)
         
         Erase 配列
            
         Application.StatusBar = "読み込み中です．．．．" & ファイル数 & " " & ファイル名

         '*************データの読み込み***********
          Do Until 入力テキストストリームオブジェクト.AtEndOfStream
              
               ' レコードの読み込み
               入力行 = 入力テキストストリームオブジェクト.ReadLine
               
               If InStr(入力行, "Click to view recent revisions list for this page") > 0 Then

                  配列(1, 1) = ファイル名
                  配列(1, 2) = Mid(入力行, InStr(入力行, "Click to view recent revisions list for this page") + 51, 10)
'                  Stop
                  Range("A1").Cells(出力行数, 1).Resize(1, 2) = 配列
                  出力行数 = 出力行数 + 1

                  Exit Do
               End If
              
          Loop  ' 最終行まで繰り返す
          
          ' 指定ファイルをCLOSE
          入力テキストストリームオブジェクト.Close
          'オブジェクトを解放する
          Set 入力テキストストリームオブジェクト = Nothing

      End If 'html ファイルのみ
      
   Next '★ファイル

    '**************終了処理*********************
    
   'オブジェクトを解放する
   Set フォルダ = Nothing
   Set ファイルシステムオブジェクト = Nothing

    終了時刻 = Now()
    MsgBox "処理が終了しました。" & Chr(13) & _
    "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly
    
    Range("A1").Activate
    Application.StatusBar = False

End Sub

Option Explicit

Dim ファイル名 As String

Dim 入力行 As String
Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
Dim 入力テキストストリームオブジェクト As Object    ' TextStream
Dim 現在のパス As String
Dim フォルダ As Object
Dim ファイル As Object
Dim 開始日時 As Variant
Dim 終了日時 As Variant
Dim 取得1文字列 As String
Dim 取得1前タグ As String
Dim 取得1後タグ As String
Dim 取得2文字列 As String
Dim 取得2キー As String

Dim カウンタ As Integer


Sub 文字列抽出()

   開始日時 = Now                ' 開始時刻を変数に格納します。
   
   取得1前タグ = "<TITLE>"
   取得1後タグ = "</TITLE>"
   取得2キー = "Keyword"
   
   カウンタ = 1
   ThisWorkbook.Worksheets("Sheet1").Activate
   
   現在のパス = ThisWorkbook.Path
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
      
   Set フォルダ = ファイルシステムオブジェクト.GetFolder(現在のパス)

   '★Excelの存在するフォルダの全てのファイルを対象
   For Each ファイル In フォルダ.Files
      
      ファイル名 = ファイル.Path
      '拡張子 htm を対象
      If InStr(ファイル名, ".htm") > 0 Then
         
         取得1文字列 = ""
         取得2文字列 = ""
      
         カウンタ = カウンタ + 1
         Range("A1").Cells(カウンタ, 1).Value = Dir(ファイル名)
         
         ' 指定ファイルをOPEN(入力モード)
         Set 入力テキストストリームオブジェクト = _
         ファイルシステムオブジェクト.OpenTextFile(ファイル名, 1)
         
         '*************データの読み込み***********
          Do Until 入力テキストストリームオブジェクト.AtEndOfStream
              
            ' レコードの読み込み
            入力行 = 入力テキストストリームオブジェクト.ReadLine
            
            If InStr(入力行, 取得1前タグ) > 0 _
            And InStr(入力行, 取得1後タグ) > 0 Then
              
               取得1文字列 = Mid(入力行, Len(取得1前タグ) + 1, InStr(入力行, 取得1後タグ) - Len(取得1前タグ) - 1)
               Range("B1").Cells(カウンタ, 1).Value = 取得1文字列

            End If
            
            If InStr(入力行, 取得2キー) > 0 Then
              
               取得2文字列 = Mid(入力行, InStr(入力行, "VALUE") + 7, Len(入力行) - InStr(入力行, "VALUE") - 8)
               Range("C1").Cells(カウンタ, 1).Value = 取得2文字列

               Exit Do
            End If

         Loop ' 最終行まで繰り返す
         
         ' 指定ファイルをCLOSE
         入力テキストストリームオブジェクト.Close
         Set 入力テキストストリームオブジェクト = Nothing
      End If
      
   Next '★ファイル
        
   Set ファイルシステムオブジェクト = Nothing
   
   終了日時 = Now
   MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub

Option Explicit

'MIDIの情報をGET
'https://hp.vector.co.jp/authors/VA030681/VBTips/MIDI.htm

'MIDIのヘッダー構成
Private Type tagMIDIHeader
    MThd                 As String * 4 '(固定長の文字列)
    HeaderLength(3)   As Byte
    MIDIFormat(1)           As Byte
    TrackCount(1)     As Byte
    TCount(1)           As Byte
    MTrk                  As String * 4 '(固定長の文字列)
    TrackLength(4)     As Byte
End Type

'String * 4 は、変数の長さを固定する為の物です｡
'例えば
'Dim 番号1 As String * 4
'Dim 番号2 As String * 4として、
'RSet 番号1 = 1
'RSet 番号2 = 999
'とすると､
'番号1には ***1（*は空文字）という文字列が入ります。
'番号2には *999（*は空文字）という文字列が入ります。
'このように数字の左側を空白で埋めた右詰の番号ができます｡

'****************************
'MIDIのヘッダー情報を得る
Function GetMIDIInfo(filename As String) As String
    Dim MIDIHeader As tagMIDIHeader
    Dim Title As String
    Dim Copyright As String
    Dim Text As String
    Dim Text2 As String
    Dim Marker As String
    Dim DateType(2) As Byte
    Dim StrtPos As Integer    'フレームの始まりの場所
    Dim FN As Long
    Dim ループ数 As Integer

    On Error Resume Next

    FN = FreeFile
    Open filename For Binary As FN
    
     'ファイルが異常
    If LOF(FN) <= 20 Then
        GetMIDIInfo = ""
        Close
        Exit Function
    End If

    Get FN, , MIDIHeader

    'MIDIではないとき
'    If MIDIHeader.MThd = "MThd" Then
    If MIDIHeader.MThd <> "MThd" Then
        GetMIDIInfo = ""
        Close
        Exit Function
    End If

    '23バイトがヘッダーでその直後からフレームが始まるので
    Get FN, 24, DateType
    StrtPos = 24

    'フレームヘッダーがある限りループ
    ループ数 = 0
    Do While DateType(0) = &HFF 'ヘキサから10進に変換：Val("&HFF") = 255、Hex(255) = FF
      ループ数 = ループ数 + 1
      If ループ数 > 200 Then Exit Do '異常ループから抜ける D:\MIDI\freemidi.org T. Rex-BabyBoomerang.mid
        Select Case DateType(1)
        'DateType(1) FFの後の区分   3タイトル、2著作権、1テキスト←テキストが3の場合もある
        'フレームヘッダー  内容 FF 01 nn テキスト、FF 02 nn 著作権関連、FF 03 nn トラック名
        'nn は内容の長さです｡
        '【重要】FF の直前に区切りの NUL (null文字 Chr(0))が入ります。
        'nn は「半角」ベースの文字数です。
        'このため内容に全角文字があると、文字数で取得した範囲が、後ろの FF 部分まで取得してしまいます。
        '下記のマクロでは NUL (null文字 Chr(0))を検出して、NUL 以降を切り捨てて全角対応しています。
        
            Case &H1
               If Text = "" Then
                  Text = Space$(DateType(2)) 'DateType(2) 内容の長さ
                  Get FN, StrtPos + 3, Text
                  '↑この+3はフレームヘッダーの分
                  Text = Replace(Text, vbCrLf, " ") '0D 0A = vbCrLf = Chr(13) & Chr(10) 
                  Text = Replace(Text, vbLf, " ")   '0A = vbLf = Chr(10)
                  'Chr(0)   NUL (null文字)
                  If InStr(Text, Chr(0)) > 1 Then
                     Text = Left(Text, InStr(Text, Chr(0)) - 1)
                  End If
               Else
                   Text2 = Space$(DateType(2))
                   Get FN, StrtPos + 3, Text2
                   '↑この+3はフレームヘッダーの分
                   Text2 = Replace(Text2, vbCrLf, " ") '0D 0A = vbCrLf = Chr(13) & Chr(10) 
                   Text2 = Replace(Text2, vbLf, " ")   '0A = vbLf = Chr(10)
                  'Chr(0)   NUL (null文字)
                  If InStr(Text2, Chr(0)) > 1 Then
                     Text2 = Left(Text2, InStr(Text2, Chr(0)) - 1)
                   End If
                   Text = Replace(Text, vbLf, " ")   '0A = vbLf = Chr(10)
                   'Asc()、AscB()、AscW() の関数は、Chr()、ChrB()、ChrW() の逆
                   '<LF>  0A 10、<CR><LF> 0D 0A 13 10、<CR>  0D 13
                   Text = Text & Text2
                End If
            Case &H2
                If Copyright = "" Then
                    Copyright = Space$(DateType(2))
                    Get FN, StrtPos + 3, Copyright
                    Copyright = Replace(Copyright, vbCrLf, " ") '0D 0A = vbCrLf = Chr(13) & Chr(10) 
                    Copyright = Replace(Copyright, vbLf, " ")   '0A = vbLf = Chr(10)
                    'Chr(0)   NUL (null文字)
                     If InStr(Copyright, Chr(0)) > 1 Then
                        Copyright = Left(Copyright, InStr(Copyright, Chr(0)) - 1)
                     End If
                End If
            Case &H3
                If Title = "" Then
                   Title = Space$(DateType(2))
                   Get FN, StrtPos + 3, Title
                   Title = Replace(Title, vbCrLf, " ") '0D 0A = vbCrLf = Chr(13) & Chr(10) 
                   Title = Replace(Title, vbLf, " ")   '0A = vbLf = Chr(10)
                  'Chr(0)   NUL (null文字)
                  If InStr(Title, Chr(0)) > 1 Then
                     Title = Left(Title, InStr(Title, Chr(0)) - 1)
                  End If

                ElseIf Text = "" Then
                    Text = Space$(DateType(2))
                    Get FN, StrtPos + 3, Text
                    '↑この+3はフレームヘッダーの分
                     Text = Replace(Text, vbCrLf, " ") '0D 0A = vbCrLf = Chr(13) & Chr(10) 
                     Text = Replace(Text, vbLf, " ")   '0A = vbLf = Chr(10)
                     'Chr(0)   NUL (null文字)
                     If InStr(Text, Chr(0)) > 1 Then
                        Text = Left(Text, InStr(Text, Chr(0)) - 1)
                     End If
                End If
            Case &H6
'            Stop
                If Text = "" Then
                    Text = Space$(DateType(2))
                    Get FN, StrtPos + 3, Text
'                     Stop
                        Text = Replace(Text, vbCrLf, " ") '0D 0A = vbCrLf = Chr(13) & Chr(10) 
                        Text = Replace(Text, vbLf, " ")   '0A = vbLf = Chr(10)
                     'Chr(0)   NUL (null文字)
                     If InStr(Text, Chr(0)) > 1 Then
                        Text = Left(Text, InStr(Text, Chr(0)) - 1)
                     End If
'                     Stop
                Else
                    Marker = Space$(DateType(2))
                    Get FN, StrtPos + 3, Marker
                    '↑この+3はフレームヘッダーの分
                     Marker = Replace(Marker, vbCrLf, " ") '0D 0A = vbCrLf = Chr(13) & Chr(10) 
                     Marker = Replace(Marker, vbLf, " ")   '0A = vbLf = Chr(10)
                     'Chr(0)   NUL (null文字)
                     If InStr(Marker, Chr(0)) > 1 Then
                        Marker = Left(Marker, InStr(Marker, Chr(0)) - 1)
                     End If
                     Text = Text & " " & Marker
                End If
        End Select
        
        StrtPos = StrtPos + DateType(2) + 4
        '↑この+4はフレームヘッダーの分の3と、次の始まりの位置は
        '今のデーターの長さ+位置+１なので
        Get FN, StrtPos, DateType
    Loop
    
    Close

    GetMIDIInfo = Title & vbTab & Copyright & vbTab & Text
'    Stop
    
    'オリジナル
'      GetMIDIInfo = "タイトル　　　：" & Title & vbCrLf & _
'      "著作権　　　　：" & Copyright & vbCrLf & _
'      "その他　　　　：" & Text & vbCrLf & _
'      "フォーマット 　：" & CStr(MIDIHeader.FileFormat(0) * &HFF + _
'                                        MIDIHeader.FileFormat(1)) & vbCrLf & _
'      "トラック数 　　：" & CStr(MIDIHeader.TrackCount(0) * &HFF + _
'                                       MIDIHeader.TrackCount(1)) & vbCrLf & _
'      "分解率　　　　：" & CStr(MIDIHeader.TCount(0) * &HFF + _
'                                        MIDIHeader.TCount(1)) & vbCrLf

End Function

Option Explicit
Option Base 1

'05：2024/10/02：ファイルサイズ追加
'06：2024/10/03：半角全角判定修正
'06：2024/10/03：半角全角判定修正をさらに修正
'07：2024/10/03：半角全角判定修正と改行修正
'08：2024/10/03：全角を含む部分の取得方法を変更
'09：2024/10/05：マーカー取得追加

'Application.FileSearch
'実行時エラー'445':
'オブジェクトはこの動作をサポートしていません｡
'2007からFileSearchは非表示になった｡

'サブフォルダ内のファイルを含めた
'MIDIファイルのリストを作成するプログラムです｡
'配列ファイルリスト内にファイル名とパスを抽出するので
'FileSearchの代替として使えます。

   Dim フルパス As String
   Dim 入力ファイル名 As String
   Dim 処理ファイル数 As Long
   
Sub ファイルリスト一覧()

   Dim フォルダパス As String
   Dim エラーカウント As Integer
   Dim 拡張子 As String
   Dim メッセージ As String
   Dim 開始日時 As Variant
   Dim 終了日時 As Variant
   Dim 既存データ As Integer
   
   Dim 追加シート名初期 As String
   Dim 追加シート名 As String
   Dim 重複 As Integer
   Dim シート As Worksheet
   Dim シート数 As Integer

    追加シート名初期 = "MIDIファイル情報"
    追加シート名 = 追加シート名初期

    For 重複 = 1 To 100
    ' 100枚まで追加しても重複しないように追番を設定します。
        For Each シート In Worksheets
            If シート.Name = 追加シート名 Then
                追加シート名 = 追加シート名初期 & "(" & 重複 & ")"
            End If
        Next シート
    Next 重複
    シート数 = Worksheets.Count
    Worksheets("テンプレート").Copy After:=Worksheets(シート数)
    ActiveSheet.Name = 追加シート名

    ThisWorkbook.Worksheets("スタート").Activate
    
    拡張子 = LCase("mid") '決め打ち

    '対象フォルダはこのExcelファイルの保存フォルダ
    フォルダパス = ThisWorkbook.Path
   
    開始日時 = Now                ' 開始時刻を変数に格納します。

    処理ファイル数 = 0
    Worksheets(追加シート名).Activate
    
    Call ファイル検索(フォルダパス, 拡張子)
    
'    TextToColumnsメソッドで上書き確認を非表示に
    Application.DisplayAlerts = False
'    https://www.relief.jp/docs/excel-vba-not-show-over-wright-range-texttocolumns-method.html
   Columns("D:D").TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
   TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    FieldInfo _
   :=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
    
    Range("A3").Select

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

    Exit Sub  'エラー以外は、以下のラベル部分を実行させないためのテクニック。

エラー表示:

    エラーカウント = エラーカウント + 1
    メッセージ = "エラーが発生しました。" & Chr(13) _
    & "フォルダパス= " & フォルダパス & Chr(13) _
    & "フルパス= " & フルパス & Chr(13) _
    & "処理ファイル数= " & 処理ファイル数 & Chr(13) _
    & "ActiveWorkbook名= " & ActiveWorkbook.Name & Chr(13) _
    & "エラー番号 " & Str(Err.Number) & Err.Source & _
    " でエラーが発生しました。" & Chr(13) & Err.Description
    
    MsgBox メッセージ, , "エラー", Err.HelpFile, Err.HelpContext
    
    ActiveWorkbook.Close False

    If エラーカウント > 5 Then Exit Sub
    Resume Next
End Sub


Private Sub ファイル検索(フォルダパス As String, 拡張子 As String)
'再帰処理でファイル抽出
    Dim n0 As Long
    Dim s0 As String
    Dim v0 As Variant
    Dim フォルダ As Object
    Dim o0 As Object
    Dim o1 As Object
    Dim ファイルシステムオブジェクト As Object
         
    Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
     
    If Not ファイルシステムオブジェクト.FolderExists(フォルダパス) Then
        Exit Sub
    End If
    
    Set フォルダ = ファイルシステムオブジェクト.GetFolder(フォルダパス)
    Set o0 = フォルダ.Files
    For Each o1 In o0
        フルパス = o1.Path
'        If Right(フルパス, Len(フルパス) - InStrRev(フルパス, ".")) Like 拡張子 Then
        If LCase(ファイルシステムオブジェクト.GetExtensionName(フルパス)) Like 拡張子 Then
            処理ファイル数 = 処理ファイル数 + 1
            If 処理ファイル数 Mod 1000 = 0 Then
               Application.StatusBar = "処理ファイル数= " & 処理ファイル数
            End If
            
            Range("A3").Cells(処理ファイル数, 1).Value = o1.ParentFolder
            Range("A3").Cells(処理ファイル数, 2).Value = o1.Name
            '=== I'll Be Back ===
            Range("A3").Cells(処理ファイル数, 4).Value = Replace(GetMIDIInfo(フルパス), "=", "")
            'Excel のセルに「=」から始まるデータを入力するとオーバーフローします
            'D:\MIDI\freemidi.org AbolishGovernment亡uperficialLove.mid
            'フルパス = Chr(34) & フルパス & Chr(34)
            On Error Resume Next
            Range("A3").Cells(処理ファイル数, 3).Value = _
            WorksheetFunction.RoundUp(FileLen(フルパス) / 1024, 0)   ' KB
'            Stop
        End If
    Next

    DoEvents
     
    Set o0 = フォルダ.SubFolders
    For Each o1 In o0
        If (o1.Attributes And (2 + 4)) = 0 Then
            Call ファイル検索(o1.Path, 拡張子)
        End If
    Next
    
    Set ファイルシステムオブジェクト = Nothing
End Sub

Option Explicit
Option Base 1

Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" ( _
                                                                  ByVal hwnd As Long, _
                                                                  ByVal pszPath As String, _
                                                                  ByVal psa As Long) As Long


Dim 入力ファイル群 As Variant

Dim 処理カウンタ As Integer
Dim 開始時刻 As Variant
Dim 終了時刻 As Variant
Dim 現在のパス As String
Dim ピリオド位置 As Integer
Dim ファイル名 As String


Sub ファイル圧縮のみ()

   Call ファイルを開くダイアログで複数ファイルを選択して圧縮
   
    終了時刻 = Now()
    MsgBox "処理が終了しました。" & Chr(13) & _
    "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly

End Sub


Sub ファイル圧縮して元ファイルを削除()

   Call ファイルを開くダイアログで複数ファイルを選択して圧縮
   Call ファイルを削除
   
    終了時刻 = Now()
    MsgBox "処理が終了しました。" & Chr(13) & _
    "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly

End Sub


Private Sub ファイルを削除()
   For 処理カウンタ = 1 To UBound(入力ファイル群)
       Kill 入力ファイル群(処理カウンタ)
   Next 処理カウンタ
End Sub


Private Sub ファイルを開くダイアログで複数ファイルを選択して圧縮()

    'このマクロのExcelのフォルダをデフォルトとする
    ChDrive ActiveWorkbook.Path
    ChDir ActiveWorkbook.Path

    '変換対象のファイル名とパス取得
    入力ファイル群 = Application.GetOpenFilename _
    (FileFilter:="テキストファイル,*.txt;*.csv", Title:="圧縮対象のファイル(複数可)を指定して下さい", MultiSelect:=True)

   'キャンセルが押された時の処理
   'http://tarohome.web.fc2.com/CCP035.html
   'http://okwave.jp/qa/q291242.html
   If IsArray(入力ファイル群) = False Then
      MsgBox "ファイルが指定されていません！"
      Stop
      Exit Sub
   End If

   開始時刻 = Now()
       
   For 処理カウンタ = 1 To UBound(入力ファイル群)
      ピリオド位置 = InStrRev(入力ファイル群(処理カウンタ), ".")
      ファイル名 = Left(入力ファイル群(処理カウンタ), ピリオド位置 - 1)

      'http://scripting.cocolog-nifty.com/blog/2007/11/vbazip_a144.html
       Call MakeZIP(ファイル名 & ".zip", 入力ファイル群(処理カウンタ))
   Next 処理カウンタ

End Sub

Sub ファイルを開くダイアログで複数ファイルを選択して解凍()
   Dim ロング As Long
   Dim 解凍先パス As String

    'このマクロのExcelのフォルダをデフォルトとする
    ChDrive ActiveWorkbook.Path
    ChDir ActiveWorkbook.Path
    
    'http://officetanaka.net/other/extra/tips07.htm
    解凍先パス = ActiveWorkbook.Path & "\解凍済\"
    ロング = SHCreateDirectoryEx(0&, 解凍先パス, 0&)

    '変換対象のファイル名とパス取得
    入力ファイル群 = Application.GetOpenFilename _
    (FileFilter:="圧縮ファイル,*.zip", Title:="解凍する圧縮ファイル(複数可)を指定して下さい", MultiSelect:=True)

   'キャンセルが押された時の処理
   'http://tarohome.web.fc2.com/CCP035.html
   'http://okwave.jp/qa/q291242.html
   If IsArray(入力ファイル群) = False Then
      MsgBox "ファイルが指定されていません！"
      Stop
      Exit Sub
   End If

   開始時刻 = Now()
       
   For 処理カウンタ = 1 To UBound(入力ファイル群)
      ファイル名 = 入力ファイル群(処理カウンタ)
      'http://blogger.u-mu.net/2011/11/vbazipwo.html
       Call unZip(ファイル名, 解凍先パス)
   Next 処理カウンタ

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

'Windows Script Programming

'http://scripting.cocolog-nifty.com/blog/2007/11/vbazip_a144.html
'VBAでZIP圧縮する｡VBScriptからVBAに焼き直し｡

Sub MakeZIP(zipFile As String, ParamArray Files() As Variant)
   Dim fso As Object
   Dim Shell As Object
   Dim zFolder As Object
   Dim Path As Variant
   Dim FileName As String
   Dim sFolderItem As Object
   Dim zFolderItem As Object
   Dim Count As Long
   Dim Ans As Long
   
   Set fso = CreateObject("Scripting.FileSystemObject")
   If UCase(fso.GetExtensionName(zipFile)) <> "ZIP" Then
     MsgBox "Invalid Extension Name - " & zipFile, vbCritical
     Exit Sub
   End If
   
   If Not fso.FileExists(zipFile) Then
     fso.CreateTextFile(zipFile, False).Write "PK" & Chr(5) & Chr(6) & String(18, 0)
   End If
   
   Set Shell = CreateObject("Shell.Application")
   Set zFolder = Shell.NameSpace(fso.GetAbsolutePathName(zipFile))
   
   For Each Path In Files
     FileName = fso.GetFileName(Path)
     Set sFolderItem = Shell.NameSpace(fso.GetParentFolderName(fso.GetAbsolutePathName(Path))).ParseName(FileName)
     If sFolderItem Is Nothing Then
       MsgBox Path & " - Not Found.", vbCritical
       Exit For
     End If
     Do
       Set zFolderItem = zFolder.ParseName(FileName)
       If zFolderItem Is Nothing Then
         Count = zFolder.Items().Count
         zFolder.CopyHere sFolderItem
         Do While zFolder.Items().Count <= Count
           Application.Wait Now + TimeSerial(0, 0, 1)  '待ちを入れる
         Loop
         Exit Do
       Else
         Ans = MsgBox("このフォルダには既に次のファイルが存在します:" & vbLf & vbLf & _
                    """" & FileName & """" & vbLf & vbLf & "既存のファイルと置き換えますか?", _
                    vbYesNoCancel + vbQuestion, "ファイル置換の確認")
         Select Case Ans
         Case vbYes
           zFolderItem.InvokeVerb ("delete")
         Case vbNo
           Exit Do
         Case vbCancel
           Exit For
         End Select
       End If
     Loop
   Next
End Sub

'http://blogger.u-mu.net/2011/11/vbazipwo.html
'Zipファイル展開関数
'および
'http://park7.wakwak.com/~efc21/cgi-bin/exqalounge.cgi?print+201208/12080001.txt

'sZipFile: 解凍したいZipファイルのフルパス｡
'sDir: 解凍先のディレクトリ｡
'bFlgDel:解凍後、Zipファイルを残すか。デフォルトflase(残す)。
Sub unZip(ByVal sZipFile As String, ByVal sDir As String, Optional ByVal bFlgDel As Boolean = False)
   Dim objFileSys As Object
   Dim objShell As Object
   Dim objFile As Object
   Dim objDestination As Object
   Dim Tempフォルダ As String
   Dim 一時ディレクトリ As Object
   Dim 削除対象一時ディレクトリ As String
   
   Set objFileSys = CreateObject("Scripting.FileSystemObject")
   Set objShell = CreateObject("Shell.Application")
   
   If isFileExist(sZipFile) = True Then
   
      Set objFile = objShell.NameSpace(CStr(sZipFile))
      
      Set objDestination = objShell.NameSpace(CStr(sDir))
      objDestination.CopyHere objFile.Items
      
      ' 問題は､ここで､zip の一時ディレクトリがユーザのtemp に残ってしまう。
      'http://mishika.blog.so-net.ne.jp/2010-08-15
      'http://www.atmarkit.co.jp/fwin2k/operation/wsh11/wsh11_01.html
      'GetSpecialFolderメソッドでは、どの特殊フォルダを取得するかを整数値で指定する。
      '具体的には、Windowsフォルダは0、Systemフォルダは1、Tempフォルダは2を指定する。
      Tempフォルダ = objFileSys.GetSpecialFolder(2).Path

         For Each 一時ディレクトリ In objFileSys.GetFolder(Tempフォルダ).SubFolders
          If InStr(一時ディレクトリ.Name, objFileSys.GetBaseName(sZipFile)) > 0 Then

            削除対象一時ディレクトリ = Tempフォルダ & "\" & 一時ディレクトリ.Name

            objFileSys.DeleteFolder 削除対象一時ディレクトリ, True 'True：読み取り専用も削除する区分

          End If
        Next
  
      If bFlgDel Then Kill sZipFile
      
      Set objDestination = Nothing
      Set objFile = Nothing
   
   End If
   
   Set objShell = Nothing
   Set objFileSys = Nothing
   
End Sub

Option Explicit
Option Base 1

   Dim ファイル_システム_オブジェクト As Object          ' FileSystemObject
   Dim フォルダ_オブジェクト As Object
   Dim サブフォルダ_オブジェクト As Object
   Dim ファイル_オブジェクト As Object
   Dim フォルダパス As String
   Dim 拡張子 As String
   Dim 対象拡張子 As String
   Dim コピー済ファイル名(10000, 3) As Variant '拡張子無しファイル名,同一ファイル名のファイル数,代表コピー元ファイルパス
   Dim コピー済ファイル名数 As Integer
   Dim 対象ファイル名先頭文字列(10) As String
   Dim 対象ファイル名先頭文字列数 As Integer
   Dim コピー元フォルダフルパス As String
   Dim コピー先フォルダフルパス As String
   Dim カウンタ As Integer
   Dim カウンタ2 As Integer
   Dim ファイル名拡張子付 As String
   Dim コピー元ファイルフルパス As String
   
   
Sub 対象ファイルをコピー()

   Dim フォルダを選択するダイアログ As Object
   Dim 最終行 As Integer
   Dim 処理行 As Integer
   Dim 開始日時 As Variant
   Dim 終了日時 As Variant
   Dim ボタン判定 As Boolean
   

   '★★★ファイルの対象条件を読み込む★★★
   ThisWorkbook.Worksheets("Sheet1").Activate
   対象拡張子 = Range("A6").Value
   最終行 = Cells(ActiveSheet.Rows.Count, 2).End(xlUp).Row
   対象ファイル名先頭文字列数 = 最終行 - 5
   For 処理行 = 1 To 対象ファイル名先頭文字列数
      対象ファイル名先頭文字列(処理行) = Range("B6").Cells(処理行, 1).Value
   Next 処理行
   
   '★★★コピー元とコピー先のフォルダを指定する★★★
   'コピー元フォルダを指定
   Set フォルダを選択するダイアログ = Application.FileDialog(msoFileDialogFolderPicker)
   
   '初期フォルダを指定
   フォルダを選択するダイアログ.InitialFileName = ActiveWorkbook.Path
   'タイトルを設定
   フォルダを選択するダイアログ.Title = "コピー元フォルダを指定して下さい"

   ボタン判定 = フォルダを選択するダイアログ.Show
    
   If ボタン判定 Then
      コピー元フォルダフルパス = フォルダを選択するダイアログ.SelectedItems(1)
   Else
      MsgBox "フォルダ選択がキャンセルされました。"
      Set フォルダを選択するダイアログ = Nothing
      Exit Sub
   End If
   
   Set フォルダを選択するダイアログ = Nothing
      
   'コピー先フォルダを指定
   Set フォルダを選択するダイアログ = Application.FileDialog(msoFileDialogFolderPicker)
   
   '初期フォルダを指定(コピー元フォルダフルパスの上位フォルダ)
   フォルダを選択するダイアログ.InitialFileName = Left(コピー元フォルダフルパス, InStrRev(コピー元フォルダフルパス, "\") - 1)
   'タイトルを設定
   フォルダを選択するダイアログ.Title = "コピー先フォルダを指定して下さい"

   ボタン判定 = フォルダを選択するダイアログ.Show
    
   If ボタン判定 Then
      コピー先フォルダフルパス = フォルダを選択するダイアログ.SelectedItems(1)
   Else
      MsgBox "フォルダ選択がキャンセルされました。"
      Set フォルダを選択するダイアログ = Nothing
      Exit Sub
   End If
   
   開始日時 = Now                ' 開始時刻を変数に格納します。

   '★★★コピー処理★★★
   Set ファイル_システム_オブジェクト = CreateObject("Scripting.FileSystemObject")
   
   Call フォルダを次々調べて対象ファイルをコピー(ファイル_システム_オブジェクト.getfolder(コピー元フォルダフルパス))
    
   Set ファイル_システム_オブジェクト = Nothing
   Set フォルダを選択するダイアログ = Nothing
   
   Call ファイル一覧をシートに出力
   
   終了日時 = Now
   MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"
   
End Sub



Private Sub フォルダを次々調べて対象ファイルをコピー(Folder As Object)

   Set フォルダ_オブジェクト = ファイル_システム_オブジェクト.getfolder(Folder)

   For Each ファイル_オブジェクト In フォルダ_オブジェクト.Files
   
      ファイル名拡張子付 = ファイル_オブジェクト.Name
      拡張子 = ファイル_システム_オブジェクト.GetExtensionName(ファイル名拡張子付)
      コピー元ファイルフルパス = ファイル_オブジェクト.Path

      If 拡張子 = 対象拡張子 Then
         
         If 対象ファイル名先頭文字列数 >= 1 Then
         '接頭辞が指定されている場合
            For カウンタ = 1 To 対象ファイル名先頭文字列数
               If InStr(ファイル名拡張子付, 対象ファイル名先頭文字列(カウンタ)) = 1 Then

                  Call ファイル名の重複を考慮してコピー
                        
               End If '対象ファイル名接頭辞
            Next カウンタ
            
         Else
         '接頭辞の指定が無い場合は全ファイルを対象に
            Call ファイル名の重複を考慮してコピー
         End If
      
      End If '対象拡張子
   Next

   'サブフォルダについても同様に行う
   For Each サブフォルダ_オブジェクト In Folder.SubFolders
      If サブフォルダ_オブジェクト.Path <> コピー先フォルダフルパス Then
         'コピー元は、コピー先フォルダ以外を対象にする
         Call フォルダを次々調べて対象ファイルをコピー(サブフォルダ_オブジェクト)
      End If
   Next
   
End Sub



Private Sub ファイル名の重複を考慮してコピー()
   Dim 新規 As Boolean
   Dim コピー先ファイルフルパス As String
   
   新規 = True
   
   'コピー済ファイル名との重複を確認
   For カウンタ2 = 1 To コピー済ファイル名数
      If コピー済ファイル名(カウンタ2, 1) = Left(ファイル名拡張子付, InStrRev(ファイル名拡張子付, ".") - 1) Then
         '既存ファイル名
         新規 = False
         
         コピー済ファイル名(カウンタ2, 2) = コピー済ファイル名(カウンタ2, 2) + 1
         
         コピー先ファイルフルパス = コピー先フォルダフルパス & "\" & コピー済ファイル名(カウンタ2, 1) _
         & CStr(コピー済ファイル名(カウンタ2, 2)) & "." & 拡張子

         Exit For
      End If
   Next カウンタ2
   
   If 新規 = True Then
      '新規ファイル名
      
      コピー先ファイルフルパス = コピー先フォルダフルパス & "\" & ファイル名拡張子付
      
      コピー済ファイル名数 = コピー済ファイル名数 + 1
      コピー済ファイル名(コピー済ファイル名数, 1) = Left(ファイル名拡張子付, InStrRev(ファイル名拡張子付, ".") - 1)
      コピー済ファイル名(コピー済ファイル名数, 2) = 1
      コピー済ファイル名(コピー済ファイル名数, 3) = コピー元ファイルフルパス
   End If
   
   '★ファイルコピー操作★
   FileCopy コピー元ファイルフルパス, コピー先ファイルフルパス

End Sub



Private Sub ファイル一覧をシートに出力()

   Dim 追加シート名初期 As String
   Dim 追加シート名 As String
   Dim 重複 As Integer
   Dim シート As Worksheet
   Dim シート数 As Integer

   ThisWorkbook.Worksheets("テンプレート").Activate
   追加シート名初期 = "ファイル名一覧"
   追加シート名 = 追加シート名初期

   For 重複 = 1 To 100
   ' 100枚まで追加しても重複しないように追番を設定します。
       For Each シート In Worksheets
           If シート.Name = 追加シート名 Then
               追加シート名 = 追加シート名初期 & "(" & 重複 & ")"
           End If
       Next シート
   Next 重複
   シート数 = Worksheets.Count
   Worksheets("テンプレート").Copy After:=Worksheets(シート数)
   ActiveSheet.Name = 追加シート名
   
   Range("A2").Resize(コピー済ファイル名数, 3).Value = コピー済ファイル名

End Sub