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 オブジェクトを表す変数です。
パラメータ
使用できる定数は、次に示す 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 つの種類があります。
[ファイルを開く ] ダイアログ ボックス:
ユーザーは 1 つ以上のファイルを選択し、Execute メソッドを使用して、ホスト アプリケーションでそのファイルを開くことができます。
[名前を付けて保存 ] ダイアログ ボックス:
ユーザーは 1 つのファイルを選択し、Execute メソッドを使用して、そのファイルを保存できます。
[参照 ] ダイアログ ボックス (ファイル参照):
ユーザーは 1 つ以上のファイルを選択し、選択したファイルのパスが FileDialogSelectedItems コレクションに与えられます。
[参照 ] ダイアログ ボックス (フォルダ参照):
ユーザーは 1 つのパスを選択し、選択したパスが FileDialogSelectedItems コレクションに与えられます。
各ホスト アプリケーションは、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