DictionaryのItemに格納したExcelのRangeは更新可能か？
以前の記事でDictionaryのItemに配列を格納して、後から更新しようとして出来なかったが、懲りずに今度はRangeを格納して試してみた。
結論から言うと、今回は更新可能でした！！！
- DictionaryのItemを更新することで、ワークシートの値も更新されます。
- また、ワークシートの対象Rangeのセルの値を更新すると、DictionaryのItemを参照しても更新された値を取得できます。
サンプルコード
Public Sub dictionaryItemUpdate() Const TARGET_SHEET_NAME As String = "Sample" Const KEY_ROW As Long = 2 Const TARGET_COLUMNS As Long = 6 Dim dicRange As Dictionary Dim sLineBefore As String Dim sLine As String Dim i As Long Set dicRange = New Dictionary With Worksheets(TARGET_SHEET_NAME) '現在のセルのデータを取得、表示用に結合 For i = 1 To TARGET_COLUMNS sLineBefore = sLineBefore & vbTab & .Cells(KEY_ROW, i).Value Next i '現在のセルのデータを表示 Debug.Print "基準となるセルデータ" Debug.Print Mid$(sLineBefore, 2) & vbCrLf '対象となるRangeをDictionaryに追加 dicRange.Add 2, .Range(.Cells(KEY_ROW, 1), .Cells(KEY_ROW, TARGET_COLUMNS)) 'Dictionaryに格納されているRangeから、データを取得、表示用に結合 For i = 1 To TARGET_COLUMNS sLine = sLine & vbTab & dicRange(KEY_ROW).Parent.Cells(KEY_ROW, i).Value Next i 'Dictionaryに格納されているデータを表示 Debug.Print "Dictionaryに格納されているデータ（更新前）" Debug.Print Mid$(sLine, 2) & vbCrLf '格納したRange内のセルの値を更新 Debug.Print "ワークシートの値を更新" Debug.Print "C2(更新前):" & .Cells(KEY_ROW, 3).Value .Cells(2, 3).Value = "----- " & .Cells(KEY_ROW, 3).Value & " -----" Debug.Print "C2(更新後) :" & .Cells(KEY_ROW, 3).Value & vbCrLf 'DictionaryのItemを更新 Debug.Print "DictionaryのItemを更新" Debug.Print "D2セル相当の値を更新（更新前）:" & dicRange(KEY_ROW).Parent.Cells(KEY_ROW, 4).Value dicRange(KEY_ROW).Parent.Cells(KEY_ROW, 4).Value = "+++++ " & dicRange(KEY_ROW).Parent.Cells(KEY_ROW, 4).Value & " +++++" Debug.Print "D2セル相当の値を更新（更新後）:" & dicRange(KEY_ROW).Parent.Cells(KEY_ROW, 4).Value & vbCrLf sLine = "" 'Dictionaryに格納されているRangeから、データを取得、表示用に結合 For i = 1 To TARGET_COLUMNS sLine = sLine & vbTab & dicRange(KEY_ROW).Parent.Cells(KEY_ROW, i).Value ' sLine = sLine & vbTab & dicRange(KEY_ROW).Cells(1, i).Value Next i Debug.Print "Dictionaryに格納されているデータ（更新後）" Debug.Print "更新前:" & Mid$(sLineBefore, 2) Debug.Print "更新後:" & Mid$(sLine, 2) sLine = "" '最終のセルのデータを取得、表示用に結合 For i = 1 To TARGET_COLUMNS sLine = sLine & vbTab & .Cells(KEY_ROW, i).Value Next i '最終のセルのデータを表示 Debug.Print "最終のセルデータ" Debug.Print Mid$(sLine, 2) & vbCrLf End With End Sub
サンプルコードを試すときは、参照設定忘れると動きませんので・・・
実行結果
call dictionaryItemUpdate
基準となるセルデータ
1 4820831 1256948 AFPKAUNYAI gKoo0fpjSf ゑたさえんぐそつぢろ
Dictionaryに格納されているデータ（更新前）
1 4820831 1256948 AFPKAUNYAI gKoo0fpjSf ゑたさえんぐそつぢろ
ワークシートの値を変更
C2(更新前):1256948
C2(更新後) :----- 1256948 -----
DictionaryのItemを更新
D2セル相当の値を更新（更新前）:AFPKAUNYAI
D2セル相当の値を更新（更新後）:+++++ AFPKAUNYAI +++++
Dictionaryに格納されているデータ（更新後）
更新前:1 4820831 1256948 AFPKAUNYAI gKoo0fpjSf ゑたさえんぐそつぢろ
更新後:1 4820831 ----- 1256948 ----- +++++ AFPKAUNYAI +++++ gKoo0fpjSf ゑたさえんぐそつぢろ
最終のセルデータ
1 4820831 ----- 1256948 ----- +++++ AFPKAUNYAI +++++ gKoo0fpjSf ゑたさえんぐそつぢろ
ポイント
ItemとしてRangeを格納したので、dicRange(KEY_ROW)がRangeを返します。
なので、セルの値は、
dicRange(KEY_ROW).Parent.Cells(KEY_ROW, i).Value
のように取得していますが、Parentの有無でCellsのアドレス指定が変わってきます。
今回の例でC2のセルの値を取得したい場合、
| Parentがある場合 | dicRange(KEY_ROW).Parent.Cells(2, 3).Value |
| Parentがない場合 | dicRange(KEY_ROW).Cells(1, 3).Value |
と指定する必要があります。
Parentがある場合には、普段使用している行、列の指定となります。
Rangeに対するParent（親）なので、ParentはWorksheetとなるためです。
? typename(dicRange(KEY_ROW).Parent)
Worksheet
として確かめることが出来ます。
一方Parentがない場合には、
ワークシート全体で見れば２行目のセルですが、Dictionaryに格納したRangeの左上のセル（A2：ワークシート基準でのCells(2,1)）を１行目、１列目とみなした相対的な行、列として指定する必要があります。従って、同じ２行目なので行を「1」としなければいけません。
今回のサンプルでは、A列から始まるRangeを使用したのですが、B列以降から始まるRangeを指定した場合には、列であっても同様のことが言えます。
Parentの有無、どちらの方法でも出来ますので、どのような処理を行うかによって使い分ければよいかと思います。
最後に
うまく使えばデータベースのように、キーを指定してレコードを取得するといった使い方とかに応用できそう？
更新もできるし・・・
あとは、背景の塗りつぶしも出来ましたので、一通りのことは出来るのではないかと思われます。
Unionで纏められたRange内のセルにVBAでアクセスする（Excel）
あまり使う事はないような気がするが、複数のセル範囲の集合をひとつのRangeとした時、そのRange内のデータにどうやってアクセスするのか？やってみました。
複数のセル範囲が不連続の場合のアクセス方法を調べることが目的です。
Unionで纏める記事はそれなりにあるようですが、纏めた後にどうやってアクセスするのか書かれているサイトは多くはないようです。
まずは、以下のようなデータを用意し、赤で囲まれた部分と青で囲まれた部分を対象のRangeとすることとします。
結論から書くと
対象Range.Areas(n).Cells(row, col)
といった指定をすることで出来ます。
ポイントとなるのは、Range.Areas プロパティです。
これは、「複数領域選択範囲内のすべての範囲を表す**Areas** コレクションを返します。 読み取り専用です。」と説明されています。
複数のセル範囲の集合をひとつのRangeとして設定する
Unionメソッドを使用し、下記のように使用します。
Set r = Union(Sheet1.Range("B2:D4"), Sheet1.Range("F3:G4"))
Range("B2:D4") <===赤で囲まれた範囲
Range("F3:G4") <===青で囲まれた範囲
各セル範囲のアドレスを調べる
使うのは、Range.Address プロパティです。
セル範囲は、Areasに１から始まるインデックスにより指定します。
下記コードでは、
r.Areas(k).Address(False, False)
の部分が該当します。
今回の場合、
赤で囲まれた範囲がArea(1)
青で囲まれた範囲がArea(2)
となり、
r.Areas(1).Address(False, False)は
B2:D4
r.Areas(2).Address(False, False)は
F3:G4
が返ります。
Unionで指定した順番に返ってくるようです。（そうでないと困ります。）
ちなみに、Unionした全体の範囲は
r.Address(False, False)
で取得でき、
B2:D4,F3:G4
と返ってきます。
各セル範囲の行数、列数を調べる
r.Areas(n)が通常のRangeを返すので、それぞれ以下のように指定して取得することが出来ます。
r.Areas(n).Rows.Count r.Areas(n).Columns.Count
セルの値を取得する
Range.Cells プロパティを使用して、指定したセルにアクセスできます。
r.Areas(n).Cells(i, j).Value
ここで、Cellsに指定する行、列の値は、対象Range（各Area(n)とも）の左上のセルを１行目、１列目とした相対的指定になるようで、Cells(1,1)といった指定を行うようです。
これに関しては、サンプルコードと実行結果を見ていただいた方がわかりやすいと思います。
さらに、対象Rangeの行数、列数を超える値をCellsに指定してもエラーにはならないようです。
指定方法を間違えると、対象Rangeに含まれないセルにアクセスすることになるので注意が必要です。
例えば、
? r.Areas(1).Cells(1, 4).Value
とすると
E2
と出力され、Area(1)の列は、B～Dであるにもかかわらず、Area(1)には含まれないセルE2が参照することが出来てしまいます。
サンプルコード
Public Sub AccessToUnionRange() Dim r As Range Dim sLine As String Dim i As Long Dim j As Long Dim k As Long '複数のRangeをUnionで纏める Set r = Union(Sheet1.Range("B2:D4"), Sheet1.Range("F3:G4")) Debug.Print "エリア数：" & r.Areas.Count Debug.Print "全エリア：" & r.Address(False, False) For k = 1 To r.Areas.Count Debug.Print "エリア" & CStr(k) & "：" & r.Areas(k).Address(False, False) Next k For k = 1 To r.Areas.Count Debug.Print "----- Area" & CStr(k) & " -----" For i = 1 To r.Areas(k).Rows.Count sLine = CStr(i) & ":" For j = 1 To r.Areas(k).Columns.Count sLine = sLine & vbTab & r.Areas(k).Cells(i, j).Value Next j Debug.Print sLine Next i Next k End Sub
実行結果
Call AccessToUnionRange
エリア数：2
全エリア：B2:D4,F3:G4
エリア1：B2:D4
エリア2：F3:G4
----- Area1 -----
1: B2 C2 D2
2: B3 C3 D3
3: B4 C4 D4
----- Area2 -----
1: F3 G3
2: F4 G4
最後に
Areas(n)を指定することで、個別のセル範囲を特定することが出来、かつRange.Areas(n)がRangeオブジェクトと分かってしまえば、それほど難しくなく処理を書けそうです。
Excelワークシートに指定フォルダ（サブフォルダを含む）から画像を読み込んで貼り付けてみた
もうすぐ3月です。
私のいる会社では、月末近くになると年度末の棚卸しがあります。
担当の方がデジカメで写真を撮っては、Excelのワークシートに
ちまちまと貼り付けてはサイズと位置を調整して・・・
面倒くさそうです。（私はその作業に関しては部外者なので関係ないので、他人事）
それ（棚卸）に、完璧に対応するのはとても無理だけど、
少しだけ楽（手抜き？）が出来るかもしれない処理を作ってみました。
やることは、ざっくり言えば、画像の貼り付けとリサイズの半（もう少し少ない？）自動化。
もうちょっと詳しく言えば
- 画像のあるフォルダを指定出来ること
- 画像は、指定したフォルダのサブフォルダを含めて抽出できること
- 画像の並びは、ファイル名ではなく、ファイルのフルパスで昇順とすること
- 画像を貼り付ける先頭セルを指定できること
- 画像はセル１個につき１ファイルとすること
- 貼り付けた画像は、貼り付けるセルの大きさに一致させること（オリジナルと縦横の比率が変わってもOKということ）
といった感じでしょうか。
Option Explicit '参照設定（FileSystemObject用） 'Microsoft Scripting Runtime '貼り付けする画像があるフォルダ Private Const TARGET_FOLDER As String = "C:\Datas\棚卸写真" '画像を貼り付けるシート名 Private Const TARGET_SHEET_NAME As String = "Sheet1" '画像を貼り付ける最初のセルアドレス Private Const IMAGE_PASET_BEGIN_ADDRESS As String = "B1" '貼り付けする画像の拡張子 Private Const TARGET_EXT As String = ".png" Public Sub addPictures() Dim r As Range Dim sTargetPaths() As String Dim i As Long ReDim sTargetPaths(0) '指定フォルダにある指定拡張子の画像のパス一覧を取得 Call getTargetPaths(TARGET_FOLDER, sTargetPaths) '画像のパスを昇順で並べ替え Call sortArrayList(sTargetPaths) '画像を貼り付ける最初のセル Set r = ThisWorkbook.Worksheets(TARGET_SHEET_NAME).Range(IMAGE_PASET_BEGIN_ADDRESS) '指定のセルに画像を貼り付け Call insertImage(sTargetPaths, r) ' Call insertImage(sTargetPaths, r, 1) End Sub '指定フォルダにある指定拡張子の画像のパス一覧を取得 Private Sub getTargetPaths(ByVal sSrcFolder As String, ByRef sTargetPaths() As String) Dim fso As FileSystemObject Dim fl As Folder Dim f As File Dim sTargetFolder As String Dim lElements As Long Set fso = New FileSystemObject If Not fso.FolderExists(sSrcFolder) Then Exit Sub End If For Each fl In fso.GetFolder(sSrcFolder).SubFolders 'サブフォルダがあれば、再帰処理 Call getTargetPaths(fl.Path, sTargetPaths) Next fl For Each f In fso.GetFolder(sSrcFolder).Files '拡張子チェック If Right$(LCase(f.Name), Len(TARGET_EXT)) = TARGET_EXT Then If Right$(sSrcFolder, 1) = "\" Then sTargetFolder = sSrcFolder Else sTargetFolder = sSrcFolder & "\" End If lElements = UBound(sTargetPaths) If lElements > 0 Then lElements = lElements + 1 ReDim Preserve sTargetPaths(lElements) sTargetPaths(lElements) = sTargetFolder & f.Name ElseIf lElements = 0 Then If sTargetPaths(lElements) = "" Then sTargetPaths(lElements) = sTargetFolder & f.Name Else lElements = lElements + 1 ReDim Preserve sTargetPaths(lElements) sTargetPaths(lElements) = sTargetFolder & f.Name End If End If End If Next f End Sub Private Sub sortArrayList(ByRef sDatas() As String) Dim ws As Worksheet Dim sortRange As Range Dim vDatas As Variant Dim i As Long With ThisWorkbook.Worksheets.Add .Visible = xlSheetHidden Set sortRange = .Range("A1").Resize(UBound(sDatas) + 1) sortRange = WorksheetFunction.Transpose(sDatas) .Sort.SortFields.Clear .Sort.SortFields.Add Key:=sortRange, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With .Sort .SetRange sortRange .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With vDatas = sortRange For i = LBound(vDatas) To UBound(vDatas) sDatas(i - 1) = CStr(vDatas(i, 1)) Next i Application.DisplayAlerts = False .Delete Application.DisplayAlerts = True End With End Sub '画像を貼り付け ' ' sTargetPaths() ：貼り付ける画像のパスを格納した配列 ' r ：画像を貼り付ける最初のセル ' lIntervalRow ：画像を貼り付ける間隔（デフォルト０。省略可） ' Private Sub insertImage(ByRef sTargetPaths() As String, ByRef r As Range, Optional ByVal lIntervalRow = 0) Dim rng As Range Dim fso As FileSystemObject Dim i As Long Set fso = New FileSystemObject For i = 0 To UBound(sTargetPaths) '画像を貼り付けるセルの位置、サイズ情報取得用 Set rng = r.Offset((lIntervalRow + 1) * i) Call r.Parent.Shapes.AddPicture( _ Filename:=sTargetPaths(i), _ LinkToFile:=False, _ SaveWithDocument:=True, _ Left:=rng.Left, _ Top:=rng.Top, _ Width:=rng.Width, _ Height:=rng.Height) rng.Offset(, 1).Value = fso.GetFileName(sTargetPaths(i)) Next i End Sub
画像データはこんな感じ
実行結果
とりあえず、先頭の定数をいじれば、それなりに使えないかなぁ～
ファイルパスのソートは、一時的に追加したダミーのワークシートに配列から貼り付けて、ワークシート上でソートしてから再度配列に取り込んでます。
データ数が少ないから、セルのデータをフルスキャンしてもいいんだけど、そうしない方向でやってみました。
昔作ったクイックソートのコードを引っ張り出してきても良かったんだけど、いろいろやってみたかったので・・・
サンプルとして使用した素材は、いらすとやよりダウンロードし、使わせていただきました。
CUPS-PDFで大量のページを印刷したら、SSDの空き容量が減ってしまった
うちのノートパソコンには、250GBのSSDが載せてあって、
そこにWindows 10とManjaro Linuxをデュアルブートにして使っています。
Manjaro Linuxの/は、112GBしか割り当てしていないので空き容量不足になることは当たり前のこととなっています。
先日、CUPS-PDFを使って300ページ位のデータをPDF化しようとしたら
空き容量が足りずにPDF化出来ませんでした。
原因はそれ以前に他のファイルをPDF化した際に出来たゴミ（？）が残っていたためのようです。
その再現と、対応策を・・・
１．まずPDF作成前の空き容量の確認
２．適当なファイルを印刷
今回は、200ページ位のファイルを２つPDF化してみました。
３．ゴミ（？）が出来ていたのは、/var/spool/cups だったので、lsで確認
４．ゴミ（？）ファイルの削除
rmコマンドで、cで始まるファイルと、dで始まるファイルを削除（sudoを使って削除しようとしたけど出来なかったので、rootで削除した）
５．削除結果の確認
６．空き容量の確認
これで領域確保終了。
普段は、rmコマンド実行の際は、iオプションをつけて確認してるけど、今回は省略。
VBAのDictionaryに配列を格納して、変更してみる
どうせなので、多次元配列（３次元だけど）にしてみた。
テスト用データ
その１ 配列を格納してみる
Public Sub Dictionaryに配列を追加() Dim dicValues As Dictionary Dim lValues(1, 1, 1) As Long Dim lKey As Long Dim i As Long Dim j As Long Dim k As Long Set dicValues = New Dictionary With ThisWorkbook.Worksheets("Sheet2") For i = 2 To 9 lValues(.Cells(i, 1).Value, .Cells(i, 2).Value, .Cells(i, 3).Value) = .Cells(i, 4).Value Next i 'キー値 0で配列を追加 dicValues.Add 0, lValues Erase lValues For i = 10 To 17 lValues(.Cells(i, 1).Value - 2, .Cells(i, 2).Value, .Cells(i, 3).Value) = .Cells(i, 4).Value Next i 'キー値 1で配列を追加 dicValues.Add 1, lValues End With ' Debug.Print "Dictionary.Itemは配列？：" & IsArray(dicValues.Item(0)) Debug.Print For lKey = 0 To dicValues.Count - 1 Debug.Print "キー：" & CStr(lKey) For i = 0 To UBound(lValues, 1) For j = 0 To UBound(lValues, 2) For k = 0 To UBound(lValues, 3) Debug.Print i; j; k, dicValues.Item(lKey)(i, j, k) Next k Next j Next i Next lKey End Sub
実行してみる。
call Dictionaryに配列を追加
Dictionary.Itemは配列？：Trueキー：0
0 0 0 10000
0 0 1 10001
0 1 0 10010
0 1 1 10011
1 0 0 10100
1 0 1 10101
1 1 0 10110
1 1 1 10111
キー：1
0 0 0 20200
0 0 1 20201
0 1 0 20210
0 1 1 20211
1 0 0 20300
1 0 1 20301
1 1 0 20310
1 1 1 20311
dicValues.Item(lKey) これ自体は配列なんですね。
だから、dicValues.Item(lKey)(i, j, k)という形でアクセス出来るんですね。
その２ 追加した配列をまるまる置き換えてみる
Public Sub Dictionaryに追加した配列をまるまる置換() Dim dicValues As Dictionary Dim lValues(1, 1, 1) As Long Dim lKey As Long Dim i As Long Dim j As Long Dim k As Long Set dicValues = New Dictionary With ThisWorkbook.Worksheets("Sheet2") For i = 2 To 9 lValues(.Cells(i, 1).Value, .Cells(i, 2).Value, .Cells(i, 3).Value) = .Cells(i, 4).Value Next i '同じ配列をキー値 0と1で追加 dicValues.Add 0, lValues dicValues.Add 1, lValues For i = 10 To 17 lValues(.Cells(i, 1).Value - 2, .Cells(i, 2).Value, .Cells(i, 3).Value) = .Cells(i, 4).Value Next i 'キー値 1のItemを値の異なる配列で書き換え dicValues.Item(1) = lValues End With For lKey = 0 To dicValues.Count - 1 Debug.Print "キー：" & CStr(lKey) For i = 0 To UBound(lValues, 1) For j = 0 To UBound(lValues, 2) For k = 0 To UBound(lValues, 3) Debug.Print i; j; k, dicValues.Item(lKey)(i, j, k) Next k Next j Next i Next lKey End Sub
実行してみる。
call Dictionaryに追加した配列をまるまる置換
キー：0
0 0 0 10000
0 0 1 10001
0 1 0 10010
0 1 1 10011
1 0 0 10100
1 0 1 10101
1 1 0 10110
1 1 1 10111
キー：1
0 0 0 20200
0 0 1 20201
0 1 0 20210
0 1 1 20211
1 0 0 20300
1 0 1 20301
1 1 0 20310
1 1 1 20311
きちんと置き換わっている。
その３ ”追加した配列の要素”だけ変更出来るか？
Public Sub Dictionaryに追加した配列の要素を変更() Dim dicValues As Dictionary Dim lValues(1, 1, 1) As Long Set dicValues = New Dictionary With ThisWorkbook.Worksheets("Sheet2") 'キー値 0で無変更の配列を追加 dicValues.Add 0, lValues 'キー指定して、配列の要素を変更 dicValues.Item(0)(0, 0, 0) = .Cells(10, 4).Value If dicValues.Item(0)(0, 0, 0) <> .Cells(10, 4).Value Then Debug.Print "Not equal! orz " & vbCrLf; dicValues.Item(0)(0, 0, 0); .Cells(10, 4).Value End If End With End Sub
実行してみる。
call Dictionaryに追加した配列の要素を変更
Not equal! orz
0 20200
値は変わっていない。
dicValues.Item(0)を内容の異なる配列で上書きすることは出来るけれど
その要素dicValues.Item(0)(0, 0, 0)を書き換える事は出来ないみたい。
エラーは出ずに処理は終了するんだけどねぇ・・・
読み取り専用のような感じ。
やっぱり一旦データを変数に取り出して、編集後に再度設定するしかないのかもしれない。
VBAで休日判定処理を使って、Excelワークシートに休日カレンダーを作る
休日判定を作ったので、その応用を２。
Excelのワークシートに休日を指定色にしたカレンダーを作成してみる。
（ソースコードへのリンクは下の方に・・・）
更新履歴
2019/6/13
横１列バージョンを追加しました。
仕様みたいなもの
通常（？）の１週間横並び
- 年指定（１月から１２月）
- 年度指定（４月から翌年３月）
オプション
- 横１行に表示する月数を可変
- 書き込み基準位置指定可能
- 月と月の間のセル数可変（縦、横）
- 曜日と曜日の間のセル数可変
- 週と週の間のセル数可変
- 休日色（背景、文字）可変
縦
- 日付、曜日、休日名表示
- 書き込み基準位置指定可能
横
- 月、日（日付ではない）、曜日表示
- 書き込み基準位置指定可能
サンプル画像
（４月２９日とか、通常の休日を非休日と設定している部分もあるので、普通の正しい（？）カレンダーとは異なるのでご注意を。）
１月から１２月（３×４）
１月から１２月（４×３）
１月から１２月（６×２）
１月から１２月（３×４、日間セルあり）
４月から３月（３×４）
縦
横
事前準備
休日判定処理クラスの休日設定（の確認）
パブリックメソッド
- createCalendarY（指定年の１月から１２月までのカレンダー作成）
- createCalendarYD（指定年度の４月から３月までのカレンダー作成）
- createCalendarYMV（指定年月の縦カレンダー作成）
- createCalendarYMH（指定年月の横カレンダー作成）
ソースコード
▶クリックで展開
注意
既存のワークシートに書き込む場合、以下のコードで確認メッセージなしで、全部クリアされますので・・・
ws.Range(.Cells(1, 1), .Cells(.Rows.Count, .Columns.Count)).Clear
生成されるワークシート名は、以下の通りです。
TARGET_SHEET_PREFIX & CStr(lYear)
デフォルトのまま使うと
TARGET_SHEET_PREFIX は、"Calendar"
なので、2019年のカレンダーを作ろうとした場合、
Calendar2019
というワークシート名になります。
2021/4/11
都合により、ソースは、こちら に移動しました。
github.com
モジュール先頭の定数を適当にいじって、いろいろ試してみて下さい。
上記とは別に、CCompanyHolidayのソースも必要です。
CCompanyHoliday のソースは、こちらから持っていって下さい。
CCompanyHolidayのソースも、上記リンク にあります。
VBAで休日判定処理を使って、指定営業日数後の日付を取得する
休日判定処理を作ったので、その応用を。
「翌営業日の日付が知りたい」とか、そういった類です。
休日判定クラスモジュールを用意して、それとは別に標準モジュールを用意して、以下のコードを貼り付けます。
あとは、getNthWorkingDayに必要なパラメータを渡して呼び出します。
日数は、マイナスをつけることで、過去方向も指定できるようにしてあります。
エラー処理はあまり入れてません。（手抜きです）
2021/4/11
都合により、ソースを、こちら に移動しました。
github.com
実務レベルで、繰り返し使うようなことでもなければ
このサンプルのように、cch_ をモジュールレベルの変数にする必要はないです。
ローカル変数で問題がない場合は、だまってローカル変数にしましょう。
（なぜこうしたかは、気にしないでください）
呼び出しサンプル
Public Sub Test() Dim d1 As Date Dim d2 As Date Dim diff As Long d1 = #8/23/2018# diff = 9 Call getNthWorkingDay(d1, diff, d2) Debug.Print d1, diff, d2 diff = -5 Call getNthWorkingDay(d1, diff, d2) Debug.Print d1, diff, d2 End Sub
以下のようなカレンダーに対して実行してみた例
call Test
2018/08/23 9 2018/09/04
2018/08/23 -5 2018/08/09
