【自分用】ExcelVBAパーツ
高速化のための抑止設定
'抑止設定 Application.ScreenUpdating = False '画面更新OFF Application.Calculation = xlCalculationManual 'シート計算-手動 Application.DisplayAlerts = False '警告表示OFF '抑止設定の解除 Application.ScreenUpdating = True '画面更新ON Application.Calculation = xlCalculationAutomatic 'シート計算-自動 Application.DisplayAlerts = True '警告表示ON
フォルダ内の全ブックを開いて処理
Private Const TARGET_FOLDER_PATH As String = "" '対象フォルダパス Private Const FOLDER_SEPARATOR As String = "\" Private Const BOOK_NAME_FORMAT As String = "*.xls*" Private Const TARGET_FOLDER_PATH_WITH_SEPARATOR As String = TARGET_FOLDER_PATH & FOLDER_SEPARATOR 'フォルダ直下の全ブックを開いて処理する処理 Private Function allBookProcess(Optional editFlag As Boolean = False) Dim targetBookName As String Dim targetBook As Workbook targetBookName = Dir(TARGET_FOLDER_PATH_WITH_SEPARATOR & BOOK_NAME_FORMAT, vbNormal) Do While targetBookName <> "" Set targetBook = Workbooks.Open(Filename:=TARGET_FOLDER_PATH_WITH_SEPARATOR & targetBookName, ReadOnly:=Not (editFlag)) Call myBookProcess(targetBook) targetBook.Close SaveChanges:=editFlag targetBookName = Dir() Loop End Function 'フォルダ配下の全ブックを開いて処理する処理 '【注意】「Microsoft Scripting Runtime」への参照設定が必要。 Private Function allFolderAllBookProcess(targeFolderPath As String, Optional editFlag As Boolean = False, Optional scanSubFolderFlag As Boolean = False) Dim fso As FileSystemObject Dim topFolder As Folder Dim tempFile As File Dim targetBook As Workbook Dim subFolder As Folder Set fso = New FileSystemObject Set topFolder = fso.GetFolder(targeFolderPath) 'フォルダ直下の全ブックを開いて処理 For Each tempFile In topFolder.Files If tempFile.Name Like BOOK_NAME_FORMAT Then Set targetBook = Workbooks.Open(Filename:=tempFile.Path, ReadOnly:=Not (editFlag)) Call myBookProcess(targetBook) targetBook.Close SaveChanges:=editFlag End If Next 'フォルダ配下のサブフォルダの全ブックを開いて処理 If scanSubFolderFlag = True Then For Each subFolder In topFolder.SubFolders Call allFolderAllBookProcess(subFolder.Path, editFlag, True) Next End If End Function '開いている各ブックに対する処理 Private Function myBookProcess(myBook As Workbook) End Function
数式列追加
Private Const ADD_START_COLUMN As Integer = 4 '数式列を追加する先頭列 Private Const HEADER_START_ROW As Integer = 1 'ヘッダー行の先頭行 Private Const DATA_START_ROW As Integer = 2 'データ行の先頭行 '対象の数式列のヘッダーと数式の文字列 Private Const FORMULA_HEADER1 As String = "ヘッダー1" Private Const FORMULA1 As String = "=A2&B2" Private Const FORMULA_HEADER2 As String = "ヘッダー2" Private Const FORMULA2 As String = "=B2&C2" '数式列追加 Private Function addFormulaColumn(targetSheet As Worksheet) Dim myCalculationMode As XlCalculation Dim formulaHeaderArray As Variant Dim formulaArray As Variant myCalculationMode = Application.Calculation formulaHeaderArray = Array(FORMULA_HEADER1, FORMULA_HEADER2) '要メンテナンス formulaArray = Array(FORMULA1, FORMULA2) '要メンテナンス Application.Calculation = xlCalculationManual targetSheet.Cells(HEADER_START_ROW, ADD_START_COLUMN).Resize(1, UBound(formulaHeaderArray) + 1).Value = formulaHeaderArray With targetSheet.Cells(DATA_START_ROW, ADD_START_COLUMN).Resize(1, UBound(formulaArray) + 1) .Value = formulaArray .AutoFill .Resize(targetSheet.UsedRange.Rows.Count - DATA_START_ROW + 1, .Columns.Count) End With Application.Calculate Application.Calculation = myCalculationMode End Function
オートフィルタの絞り込み条件を保持・再適用するアイデア
導入
VBAでオートフィルタを扱う方法を調べていた際に、Office TANAKAさんの記事1で以下の記載を目にしました。
日付を年単位や月単位などで絞り込み条件を設定すると、その条件がVBAから見えなくなるのです。
これはかなり衝撃的でした。
ユーザーが設定した任意の絞り込み条件を、消した後に元に戻す仕組みがVBAには無いという事を意味しますからね。
この様な状況であってもオートフィルタの絞り込み条件を保持・再適用するアイデアを、この記事では紹介します。
アイデアの内容
Excelの以下の性質を利用します。
Excelの性質
セルの挿入／削除を行うと、オートフィルタのセル範囲が自動で拡張／縮小される。
おそらくExcel作業でオートフィルタを触ったことがある方は、身に覚えがあると思います。
この性質を利用したアイデアは次の通りです。
オートフィルタの絞り込み条件を保持・再適用するアイデア
-
編集後データの用意
絞り込み条件を再適用したい編集後データを、対象のオートフィルタとは別に用意する。 -
対象のオートフィルタのセル範囲拡張
編集後データ分のセルを挿入し、対象のオートフィルタのセル範囲を拡張させる。 -
データの差し替え
拡張されたセル範囲に編集後データを貼り付ける。
編集前データのセルを削除し、対象のオートフィルタのセル範囲を縮小させる。 -
絞り込み条件の再適用
設定されている絞り込み条件を再適用する。
具体的なイメージを順に説明していきます。
例として、以下の様な絞り込み条件が適用されたオートフィルタを扱う事にします。
1.編集後データの用意
以下の図03を見てください。
前述の図02【例】任意の絞り込み条件が適用されたオートフィルタから絞り込み条件を解除した状態が左側で、何らかの編集後の状態（絞り込み条件を再適用したい編集後データ）が右側だとします。
この右側の状態（編集後データのセル）を、別シートや別ブックなどで対象のオートフィルタとは別に用意しておきます。
2.対象のオートフィルタのセル範囲拡張
対象のオートフィルタに絞り込み条件が適用されたままの状態で、編集後データ分のセルを挿入し、対象のオートフィルタのセル範囲を拡張させます。
ただし、まだ絞り込み条件の再適用を実行していないため、値が空白である挿入したセルが表示されています。
また、行番号の青字から、対象のオートフィルタのセル範囲が拡張されていることがわかります。
3.データの差し替え
拡張されたセル範囲に編集後データを貼り付け、次に編集前データのセルを削除し対象のオートフィルタのセル範囲を縮小させます。
4.絞り込み条件の再適用
最後に、消えないように保持しておいた絞り込み条件の再適用を実行します。
実装
今回実装したコードは以下の通りです。
'【引数】 'targetAutoFilter : 絞り込み条件の保持と再適用を行う対象のAutoFilterオブジェクト 'afterEditDataRange : 編集後データが用意されているセル範囲のRangeオブジェクト（1.編集後データの用意） Private Function changeDataAndReapplyFilter(targetAutoFilter As AutoFilter, afterEditDataRange As Range) Dim beforeEditDataCount As Long '編集前データの個数 Dim afterEditDataCount As Long '編集後データの個数 Dim i As Long 'ループ処理用の整数変数 'ローカル変数の初期化 beforeEditDataCount = targetAutoFilter.Range.Rows.Count - 1 afterEditDataCount = afterEditDataRange.Rows.Count '編集後データの個数分の行挿入（2.対象のオートフィルタのセル範囲拡張） For i = 1 To afterEditDataCount targetAutoFilter.Range.Cells(2, 1).EntireRow.Insert Next '編集後データを貼り付け（3.データの差し替え） afterEditDataRange.Copy targetAutoFilter.Range.Cells(2, 1) '編集前データの行削除（3.データの差し替え） For i = 1 To beforeEditDataCount targetAutoFilter.Range.Cells(1 + afterEditDataCount + 1, 1).EntireRow.Delete Next '4.絞り込み条件の再適用 targetAutoFilter.ApplyFilter End Function
なお、お察しの通り編集前データや編集後データが0個の場合などの例外は考慮できていないので、必要に応じて組み込んでください。
補足
ActiveSheet.AutoFilterが返すオブジェクトが、状況によってWorksheet.AutoFilterが返る場合とActiveCell.ListObject.AutoFilterが返る場合があるそうです。
以下の記事で紹介されていました。
www.excel-chunchun.com
もしかするとこれが原因で悩まされることがあるかもしれません。
ファイルやフォルダのパス情報取得について（例題：拡張子一括変更マクロ）
- 導入
- ファイルやフォルダのパス情報取得の具体例まとめ
- 例題：拡張子一括変更マクロ（設計）
- 例題：拡張子一括変更マクロ（FileSystemObjectを使った実装）
- 例題：拡張子一括変更マクロ（FileSystemObjectを使わない実装）
- 補足（例外について）
- おまけ（plantUMLのソース）
導入
先日、iPhoneで撮った写真（拡張子：.heic）をアルバム作成サービスにアップロードしようとしたところ、拡張子が対応しておらず困ったという事がありました。
色々と試した結果、写真の拡張子を".jpg"に変更することで画像ファイルとしての取扱いにも差し障りなく正常にアップロードできることがわかったので、拡張子一括変更マクロを考えてみました。
その際、ファイルやフォルダのパス情報を取得・編集する必要があったので、備忘のために各メソッド等で取得できるパス情報の具体例をまとめておこうと思います。
ファイルやフォルダのパス情報取得の具体例まとめ
以下の通りです。
| オブジェクト／VBA関数 | プロパティ／メソッド | 具体例 |
|---|---|---|
| Scripting.Folder | Name | "testFolder" |
| Scripting.Folder | Path | "C:\test\testFolder" |
| Scripting.File | Name | "TestFile.jpg" |
| Scripting.File | Path | "C:\test\testFolder\TestFile.jpg" |
| Scripting.FileSystemObject | GetAbsolutePathName(パス) | "C:\test\testFolder\TestFile.jpg" |
| Scripting.FileSystemObject | GetBaseName(パス) | "TestFile" |
| Scripting.FileSystemObject | GetDriveName(パス) | "C:" |
| Scripting.FileSystemObject | GetExtensionName(パス) | "jpg" |
| Scripting.FileSystemObject | GetFileName(パス) | "TestFile.jpg" |
| Scripting.FileSystemObject | GetParentFolderName(パス) | "C:\test\testFolder" |
| VBA関数 | Dir(パス) | "TestFile.jpg" パスが存在しない場合は空文字 |
| VBA関数 | CurDir() | "C:\test\testFolder" |
| Workbook | Name | "拡張子一括変更.xlsm" |
| Workbook | FullName | "C:\test\拡張子一括変更.xlsm" |
| Workbook | Path | "C:\test" |
例題：拡張子一括変更マクロ（設計）
せっかくなので、UMLを使って設計図を描いてみます。
要件定義（やりたいことの文章化）
拡張子一括変更マクロでやりたいことを文章で定義すると、以下の様になります。
対象フォルダに存在する全てのファイルの拡張子を所定の拡張子に変更すること。 なお、対象フォルダのサブフォルダ配下の全ファイルを処理の対象とする。
設計（クラス図）
要件定義から考えて、フォルダクラスとファイルクラスを以下の様にモデル化してみました。
設計（シーケンス図）
クラス図で洗い出した操作をどの様なフローで呼び出されるべきかを考えると、サブフォルダを全て処理するためには拡張子一括変更処理を再帰呼び出しする必要がありました。
シーケンス図を以下の様に描いてみます。
設計（クラス図（再考））
シーケンス図から、「対象フォルダパス」と「変更後拡張子」の情報がクラス図に無いことに気付きました。
拡張子一括変更処理を呼び出す側がその情報を持っていることを、クラス図に追記してみます。
こんな感じでしょうか？
議論の余地はかなりあると思いますが。。。
例題：拡張子一括変更マクロ（FileSystemObjectを使った実装）
皆さんはFileSystemObjectをよく使うでしょうか？
大抵のプロパティやメソッドが揃っているので、僕はフォルダやファイルを扱うときは真っ先に飛びつきがちです。
今回もまずはFileSystemObjectを使って実装してみました。以下の通りです。
'拡張子一括変更処理（FileSystemObject使うver） Private Function changeExtensionByFso(folderPath As String, afterExtension As String) 'ローカル変数 Dim fso As FileSystemObject Dim targetFolder As Folder Dim tempFolder As Folder Dim tempFile As File 'ローカル変数初期化 Set fso = New FileSystemObject Set targetFolder = fso.GetFolder(folderPath) 'サブフォルダの取得 & サブフォルダの数だけループし、拡張子一括変更処理を再帰呼び出し。 For Each tempFolder In targetFolder.SubFolders Call changeExtensionByFso(tempFolder.Path, afterExtension) Next 'ファイルの取得 & ファイルの数だけループし、拡張子の変更を実施。 For Each tempFile In targetFolder.Files fso.MoveFile _ Source:=tempFile.Path, _ Destination:=folderPath & "\" & fso.GetBaseName(tempFile.Path) & afterExtension Next End Function
例題：拡張子一括変更マクロ（FileSystemObjectを使わない実装）
今回の記事を書くにあたって色々調べていくと、Dir関数とNameステートメントを使えばFileSystemObjectを使わなくても実装できそうだという事がわかりました。
FileSystemObjectとは違い、細かいところを気にかける必要がありましたが何とか以下の様に実装できました。
'拡張子一括変更処理（FileSystemObject使わないver） Private Function changeExtensionByRegularLibrary(folderPath As String, afterExtension As String) 'ローカル変数 Dim dirResult As String Dim subFolderPath() As String Dim filePath() As String Dim i As Integer 'ローカル変数初期化 ChDir folderPath dirResult = Dir("*", vbDirectory) ReDim subFolderPath(0) ReDim filePath(0) 'サブフォルダの取得 & ファイルの取得 Do Until dirResult = "" If dirResult <> "." And dirResult <> ".." Then If (GetAttr(dirResult) And vbDirectory) = vbDirectory Then subFolderPath(UBound(subFolderPath)) = folderPath & "\" & dirResult ReDim Preserve subFolderPath(UBound(subFolderPath) + 1) Else filePath(UBound(filePath)) = folderPath & "\" & dirResult ReDim Preserve filePath(UBound(filePath) + 1) End If End If dirResult = Dir() Loop 'サブフォルダの数だけループし、拡張子一括変更処理を再帰呼び出し。 For i = LBound(subFolderPath) To UBound(subFolderPath) - 1 Call changeExtensionByRegularLibrary(subFolderPath(i), afterExtension) Next 'ファイルの数だけループし、拡張子の変更を実施。 For i = LBound(filePath) To UBound(filePath) - 1 Name filePath(i) As Left(filePath(i), InStrRev(filePath(i), ".") - 1) & afterExtension Next End Function
Dir関数を使うと一つのループ処理でフォルダとファイル両方の名前を取得できたので、ファイルの取得処理のタイミングがシーケンス図とは乖離した状態にしました。
趣味でやっていることなので、まぁ良しとしましょう。
補足（例外について）
上記の実装では、例外を考慮していません。
より安全にするのであれば、例えば次の様な例外の処理を実装しておく必要があります。
拡張子変更後のファイルが存在している場合
例えば「photo1.heic」と「photo1.jpg」がある場合に、拡張子を".jpg"に変更するように上記のマクロを実行すると実行時エラーとなります。
拡張子変更後のファイルの存在チェックやOn Errorステートメントを利用して処理が止まらないようにすることと、何もしないのかそれとも例外情報を通知するのかといった例外の取扱い方針の決定および実装が必要になります。
拡張子無しのファイルの扱い
実際に試してみたところFileSystemObjectを使う場合は考慮する必要が無く、例えば「photo1」というファイルを「photo1.jpg」に変更することができていました。（さすが！）
FileSystemObjectを使わない場合では、"."という文字列の検索により拡張子を識別しています。該当のコードは以下の通りです。
Name filePath(i) As Left(filePath(i), InStrRev(filePath(i), ".") - 1) & afterExtension
そのため、拡張子が無い場合は以下の2通りのバグが発生することになります。
ファイルパスに1つも"."が含まれない場合
InStrRev関数の戻り値が0となるため、Left関数の引数lengthに-1を渡してしまい「引数が不正です」という実行時エラーが発生します。ファイルパスに"."が含まれる場合（いずれかの親フォルダの名前に"."が含まれる場合）
例えばファイルパスが"C:\test\folderNo.1\photo1"の場合は、ファイルパス"C:\test\folderNo.jpg"に移動されてしまいます。
対処としては、上記のコードで拡張子が無い場合の条件分岐を設けて正しい移動先ファイルパスを指定する必要があります。
おまけ（plantUMLのソース）
UMLを描くにあたっては、plantUMLを利用しました。
おまけとしてそのソースを記載しておきます。
- 01_【設計】クラス図
@startuml
skinparam defaultFontName ＭＳ ゴシック
class "フォルダ" as folder{
フォルダパス
--
サブフォルダの取得()
ファイルの取得()
}
class "ファイル" as file{
ファイルパス
--
拡張子の変更(変更後拡張子)
}
hide circle
folder "格納先フォルダ" o-- "サブフォルダ" folder
folder o-- file
@enduml
- 図02_【設計】シーケンス図
@startuml
skinparam defaultFontName ＭＳ ゴシック
title 拡張子一括変更処理(フォルダパス,変更後拡張子)
actor "VBA" as vba
participant "フォルダ" as folder
participant "ファイル" as file
vba -> folder : <<create>>\nnew(フォルダパス)
vba -> folder : サブフォルダの取得()
loop サブフォルダの数だけ
|||
ref over vba,folder,file : 拡張子一括変更処理(サブフォルダパス,変更後拡張子)
|||
end
vba -> folder : ファイルの取得()
loop ファイルの数だけ
vba -> file : 拡張子の変更(変更後拡張子)
end
@enduml
- 図03_【設計】クラス図(シーケンス図による気付きを修正)
@startuml
skinparam defaultFontName ＭＳ ゴシック
class "VBA" as vba{
対象フォルダパス
変更後拡張子
--
拡張子一括変更処理(フォルダパス,変更後拡張子)
}
together {
class "フォルダ" as folder{
フォルダパス
--
サブフォルダの取得()
ファイルの取得()
}
class "ファイル" as file{
ファイルパス
--
拡張子の変更(変更後拡張子)
}
}
hide circle
vba x.right.> folder
vba x.right.> file
folder "格納先フォルダ" o-- "サブフォルダ" folder
folder o-- file
@enduml
VBAの公式な仕様の調べ方（例題：Bookを読み取り専用で開く,Bookを新規で開く）
導入
VBAを書く際に、
あのメソッドの引数はどう指定すればいいんだっけ？
こういうプロパティは持っていないかな？
等とふと思ったことはないでしょうか？（僕は結構あります。）
そのような時はMicrosoft社のVBAリファレンスを見ると、間違いのない公式な仕様なので手っ取り早いことがあります。
VBAの公式な仕様（Microsoft社のVBAリファレンス）
VBAの公式な仕様（Microsoft社のVBAリファレンス）のページは次の通りです。
Excel VBA リファレンス docs.microsoft.com
上記のページを開くと、VBAを書く際に使用するオブジェクトと関数の仕様を調べることができます。
例題：Bookを読み取り専用で開く
Bookを読み取り専用で開くには、
'変数filePathに代入したファイルパスのBookを読み取り専用で開き、そのWorkbookオブジェクトを変数openBookに代入。 Set openBook = Workbooks.Open(Filename:=filePath, ReadOnly:=True)
WorkbooksオブジェクトのOpenメソッドで、引数ReadOnlyにTrueを指定するとBookを読み取り専用で開くことができます。
データ抽出のみが目的だったり、共有がかかっていないExcelファイルをロックしたくない等、Bookを読み取り専用で開きたい場合があると思います。
以前、確かOpenメソッドで読み取り専用を指定できたと思うけどどうだったかな？
となった際に「Workbooksオブジェクト」、「VBAリファレンス」といったキーワードで検索し、公式な仕様を調べました。
例題：Bookを新規で開く
Bookを新規で開くには、
'変数filePathに代入したファイルパスのBookを新規で開き、そのWorkbookオブジェクトを変数openBookに代入。 Set openBook = Workbooks.Add(Template:=filePath)
WorkbooksオブジェクトのAddメソッドで、引数Templateに対象のファイルパスを指定するとBookを新規で開くことができます。
実は、Bookを新規で開く方法をVBAではどうすれば良いのか、今まで知りませんでした。
例題としてBookを読み取り専用で開く方法を挙げましたが、普段の仕事では右クリックから新規で開くことが多いので今回調べてみたわけです。
ググってみると、Yahoo知恵袋で同じ質問がされていました。 detail.chiebukuro.yahoo.co.jp
見てみると、2人目の回答者が以下の様に回答しています。
Workbooks.Add ファイルフルパス
確かにWorkbooksオブジェクトのAddメソッドでBookを新規作成できますから、引数に対象のファイルパスを指定することで右クリックの新規で開くと同じことができそうですし、VBAユーザーとしてはAddメソッドにその様な機能がオーバーロードされていたら嬉しいなと思います。
実際に公式な仕様を調べてみると、確かにその様なことがきちんと記載されていました。
ちなみに情報1（開いているBookは新規で開けない）
「図04_Workbooks.Addメソッド」に、"Excel ファイルの名前を指定する文字列を指定する"という記載が見えますが、素直にファイル名（Book名）を指定して新規で開くことができるのかが気になったので試してみました。
結果は右クリックから新規で開く場合の挙動と同様に、既に開いているBookと同じ名前のBookは開けないというエラーとなります。
ちなみに情報2（Book名指定時の挙動について）
「ちなみに情報1」では意識していなかったのですが、Book名（例："VBAtest.xlsm"）を指定すると勝手にWorkbooksコレクションからBookを取得してくれるんですね。
当然ながら、VBAのカレントディレクトリにBook名のファイルが存在すればそのBookが新規で開かれることとなります。
※VBAのカレントディレクトリはCurDir関数で調べることができます。（Windowsの場合はドキュメントフォルダのようです。）
ちなみに情報3（通常通り開いたBookは新規で開けないが逆は可能）
見出しの通り、通常通り開いたBookは新規で開けませんが逆は可能です。
「test.xlsx」を通常通り開くと、VBAは"test.xlsx"という名前のWorkbookオブジェクトとして扱います。
「test.xlsx」を新規で開くと、VBAは"test1"という名前のWorkbookオブジェクトとして扱います。
「test.xlsx」を新規で開いただけでは"test.xlsx"という名前のWorkbookオブジェクトは存在しないため、「test.xlsx」を通常通り開くことが可能となるわけです。
同様に、「test.xlsx」を新規で開いた状態では"test1"というファイルをExcelで開こうとすると、同じ名前のBookは開けないというエラーとなります。
