Excel VBA ファイル操作

Excel VBA のトップに戻る
Excel VBA 目次

索引

テキスト・ファイルの特定項目を取得
([ファイルを開く]ダイアログで指定したフォルダで、指定した拡張子の全てのファイルを対象)

 FreeBASIC のヘルプ Wiki の heml(約 1千ファイル)について、そのファイル名とファイル作成日を取得するために作りました。


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

この種類の目次に戻る↑ 索引へ↓ トップページに戻る

html のタグ項目を読み込む(Excel と同じフォルダの全てのファイルを対象)

 Win32 API のヘルプ chm を作る過程で必要になったので、作成しました。

 この Excel と同じフォルダにある htm ファイルを全て読んで、ファイル名と、タイトルとキーワードを、タグ属性を使って抽出します。

 このマクロをダウンロードできます。FileNameAndTitleOfHtmlVba01.xls


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

この種類の目次に戻る↑ 索引へ↓ トップページに戻る

ファイルを開くダイアログで複数ファイルを選択して ZIP圧縮・解凍

 月次処理で、部門サーバに出力される複数の種類のダンプ・ファイルを、それぞれのファイル名で ZIP圧縮するために作りました。

 肝心の圧縮部分と解凍部分のコードは、下記を使わせていただいています。
(1).圧縮:
Windows Script Programming
VBAでZIP圧縮する。(VBScriptからVBAに焼き直し。)
http://scripting.cocolog-nifty.com/blog/2007/11/vbazip_a144.html
(2).解凍
VBAとAndroidアプリのTIPS
Zipファイル展開関数
http://blogger.u-mu.net/2011/11/vbazipwo.html
および
http://park7.wakwak.com/~efc21/cgi-bin/exqalounge.cgi?print+201208/12080001.txt
および
http://mishika.blog.so-net.ne.jp/2010-08-15

このExcelマクロをダウンロードできます。→ZipUnZipVBA02.xls

説明:ファイルを開くダイアログを使って、対象ファイルを指定します。
圧縮対象は、このマクロでは、テキストファイル(拡張子 txt csv)としています。
複数ファイルを指定した場合は、それぞれのファイルを個別に zip します。

解凍の場合は、このマクロのExcelブックのフォルダの下に、「解凍済」というフォルダを作成して、展開します。


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

この種類の目次に戻る↑ 索引へ↓ トップページに戻る

指定したフォルダのサブフォルダを含めて、条件付きファイルを検索して別フォルダにコピー

主に言語とシステム開発に関して」というサイトの、下記に興味深い事例が掲載されていました。
http://d.hatena.ne.jp/language_and_engineering/20111030/p1
・特定のフォルダ・ツリーの中から、指定した拡張子のファイルを抽出したい。
・サブディレクトリの構成ファイルも含む。
・抽出対象のファイルは、ファイル名の先頭に特定の「接頭辞」が付与されている。その接頭辞はリストにしてある。
・別のサブ元フォルダから抽出した結果、抽出後に、ファイル名がダブる場合もあり得るので、上書きせずに別ファイルとなるようにファイル名に追番を付けて保存したい。

 この要求仕様に対応した、Excel VBA を作ってみました。

このExcelマクロをダウンロードできます。→FileSelectCopyVBA04.xls

抽出元(コピー元)フォルダと、抽出先(コピー先)フォルダを指定するために、FileDialogオブジェクトを使って、「フォルダ参照」ダイアログボックスを表示させています。

参考にさせていただいたサイト
 FileDialogを使用してGetOpenFilenameではできないフォルダのみ選択できる[参照]ダイアログボックスを表示して選択されたフォルダパスを取得する方法
http://vba-geek.jp/blog-entry-294.html
 FileDialog オブジェクトの使用
https://msdn.microsoft.com/ja-jp/library/cc326127.aspx
 ファイルダイアログ(FileDialog)
http://excel-ubara.com/excelvba1/EXCELVBA376.html

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

 解説
 Application.FileDialog プロパティ は、ファイル ダイアログのインスタンスを表す FileDialog オブジェクトを返します。

構文.FileDialog(fileDialogType)

   Application オブジェクトを表す変数です。

パラメータ
名前必須/オプションデータ型説明
fileDialogType必須MsoFileDialogTypeファイル ダイアログの種類です。

 使用できる定数は、次に示す MsoFileDialogType クラスの定数のいずれかです。
msoFileDialogFilePickerユーザーがファイルを選択できます。
msoFileDialogFolderPickerユーザーがフォルダを選択できます。
msoFileDialogOpenユーザーがファイルを開くことができます。
msoFileDialogSaveAsユーザーがファイルを保存できます。


 次の使用例は、ユーザーが 1 つ以上のファイルを選択できるファイル ダイアログを開きます。
ファイルが選択されると、各ファイルのパスを別々のメッセージで表示します。
Sub UseFileDialogOpen()

    Dim lngCount As Long

    ' ファイル ダイアログを開きます。
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = True
        .Show

        ' 選択された各ファイルのパスを表示します。
        For lngCount = 1 To .SelectedItems.Count
            MsgBox .SelectedItems(lngCount)
        Next lngCount

    End With

End Sub


FileDialog オブジェクト は、Microsoft Office アプリケーションでファイルを開いたり保存する標準的な [ファイルを開く] および [保存] ダイアログ ボックスに類似するファイル ダイアログ ボックスの機能を提供します。

FileDialog オブジェクトを取得するには、FileDialog プロパティを使用します。
FileDialog プロパティは、各 Office アプリケーションの Application オブジェクト内にあります。
このプロパティは、DialogType のみを引数とし、プロパティで取得する FileDialog オブジェクトの種類を指定します。
FileDialog オブジェクトには、次の 4 つの種類があります。

各ホスト アプリケーションは、FileDialog オブジェクトのインスタンスを 1 つだけ作成できます。
したがって、複数の FileDialog オブジェクトを作成した場合でも、FileDialog オブジェクトの多くのプロパティは変更されないまま使用されます。
ダイアログ ボックスを表示する前に、すべてのプロパティが目的に応じて適切に設定されているかどうかを確認します。

FileDialog オブジェクトを使用してファイルのダイアログ ボックスを表示するには、Show メソッドを使用する必要があります。
ダイアログ ボックス表示後は、ユーザーがダイアログ ボックスを閉じるまで、コードの実行は中断されます。

次の使用例は、[参照] ダイアログ ボックスを作成して表示し、選択されたファイルをメッセージ ボックスに表示します。
Sub Main()

    'FileDialog オブジェクトの変数を宣言します。
    Dim fd As FileDialog

    '[参照] ダイアログ ボックスの FileDialog オブジェクトを作成します。
    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    '選択した各アイテムのパスを保存する
    '変数を宣言します。パスは文字列型 (String) ですが、
    '変数はバリアント型 (Variant) である必要があります。Each...Next ルーチンは、
    'バリアント型 (Variant) およびオブジェクト型 (Object) の値でのみ動作します。
    Dim vrtSelectedItem As Variant

    'With...End With ブロックを使用して、FileDialog オブジェクトを参照します。
    With fd

        'Show メソッドを使用して [参照] ダイアログ ボックスを表示し、ユーザーのアクションを取得します。
        'ユーザーがボタンをクリックしました。
        If .Show = -1 Then

            'FileDialogSelectedItems コレクション内のすべての文字列を調べます。
            For Each vrtSelectedItem In .SelectedItems

                'vrtSelectedItem は、選択した各アイテムのパスを含む文字列型 (String) の値です。
                'このパスで使用したいファイルの I/O 関数があれば、使用することができます。
                'この使用例では、メッセージ ボックスにパスを表示します。
                MsgBox "The path is: " & vrtSelectedItem

            Next vrtSelectedItem
        'ユーザーが [キャンセル] をクリックしました。
        Else
        End If
    End With

    'オブジェクト変数を Nothing に設定します。
    Set fd = Nothing

End Sub

この種類の目次に戻る↑ 索引へ↓ トップページに戻る


ホームページのトップに戻る