指定日が、月内で第何度目の何曜日かを求める(VBA)
最近、表題の処理を2件ほど、はてなブログで見かけた。
いずれの処理も、月始めから指定日までループ処理をしていたが、この手の処理は1週間(7日)の周期性があるので、それを利用してループ処理なしで求めてみた。
thom.hateblo.jp
b004nws862zx.hatenablog.com
抑えておくべきこと
第1の日曜日から土曜日は、毎月1日から7日にある。
第2の日曜日から土曜日は、毎月8日から15日にある。
以下同様
従って、
日 | 週 |
---|---|
1~7 | 1 |
8~14 | 2 |
15~21 | 3 |
22~28 | 4 |
29~31 | 5 |
となる。
7日の周期で、週が1加算されていくので、7で割った商を使えばよい。
ただし、そのまま日を7で割ってしまっては求めたい値(週)は得られない。
7で割って商が1となる整数は、7から13である。そこで1から7を7から13に補正するため、6を加算した上で、7で割ることで目的の値が得られる。
これは商が2以上の場合でも同じである。
コード
Public Function 第N○曜日(ByVal dtTargetDate As Date) As String Const DAY_OF_WEEK As String = "日月火水木金土" Dim lNthWeek As Long Dim sWeek As String '第N lNthWeek = (Day(dtTargetDate) + 6) \ 7 '曜日 sWeek = Mid$(DAY_OF_WEEK, Weekday(dtTargetDate), 1) 第N○曜日 = "第" & CStr(lNthWeek) & sWeek & "曜日" End Function
第何週目の何曜日なのかの場合
基本は上の例と同じ。
違うのは、日に対する補正値。
上の例では、単純に6を加算すればよかったが、この場合には、第1土曜日が13(7で割って商が1になる最大の整数)になるようにすればよい。
しかし、第1土曜日が何日かによって補正値が変わってくる。
1日の曜日 | 第1土曜日の日 | 第1土曜日の日を13にするために必要な値 |
---|---|---|
日 | 7 | 6 |
月 | 6 | 7 |
火 | 5 | 8 |
水 | 4 | 9 |
木 | 3 | 10 |
金 | 2 | 11 |
土 | 1 | 12 |
となることから、
第1土曜日の日+5+Weekday(1日の日付)
とすることで13を得る事が出来るので、目的の補正値が得られる。
コード
Public Function 第N週の○曜日(ByVal dtTargetDate As Date) As String Const DAY_OF_WEEK As String = "日月火水木金土" Dim dtFirstDate As Date Dim lCorrection As Long Dim lNthWeek As Long Dim sWeek As String '指定日の月の1日 dtFirstDate = DateAdd("d", -Day(dtTargetDate) + 1, dtTargetDate) '第N週計算のための補正値 lCorrection = Weekday(dtFirstDate) + 5 '第N週 lNthWeek = (Day(dtTargetDate) + lCorrection) \ 7 '曜日 sWeek = Mid$(DAY_OF_WEEK, Weekday(dtTargetDate), 1) 第N週の○曜日 = "第" & CStr(lNthWeek) & "週の" & sWeek & "曜日" End Function
実行結果
確認用コード
Public Sub 第○曜日テスト() Dim d As Date For d = #3/1/2019# To #3/31/2019# Debug.Print Format$(d, "yyyy/mm/dd"); Debug.Print vbTab; Debug.Print 第N週の○曜日(d); Debug.Print vbTab; Debug.Print 第N○曜日(d) Next d End Sub
結果
call 第○曜日テスト
2019/03/01 第1週の金曜日 第1金曜日
2019/03/02 第1週の土曜日 第1土曜日
2019/03/03 第2週の日曜日 第1日曜日
2019/03/04 第2週の月曜日 第1月曜日
2019/03/05 第2週の火曜日 第1火曜日
2019/03/06 第2週の水曜日 第1水曜日
2019/03/07 第2週の木曜日 第1木曜日
2019/03/08 第2週の金曜日 第2金曜日
2019/03/09 第2週の土曜日 第2土曜日
2019/03/10 第3週の日曜日 第2日曜日
2019/03/11 第3週の月曜日 第2月曜日
2019/03/12 第3週の火曜日 第2火曜日
2019/03/13 第3週の水曜日 第2水曜日
2019/03/14 第3週の木曜日 第2木曜日
2019/03/15 第3週の金曜日 第3金曜日
2019/03/16 第3週の土曜日 第3土曜日
2019/03/17 第4週の日曜日 第3日曜日
2019/03/18 第4週の月曜日 第3月曜日
2019/03/19 第4週の火曜日 第3火曜日
2019/03/20 第4週の水曜日 第3水曜日
2019/03/21 第4週の木曜日 第3木曜日
2019/03/22 第4週の金曜日 第4金曜日
2019/03/23 第4週の土曜日 第4土曜日
2019/03/24 第5週の日曜日 第4日曜日
2019/03/25 第5週の月曜日 第4月曜日
2019/03/26 第5週の火曜日 第4火曜日
2019/03/27 第5週の水曜日 第4水曜日
2019/03/28 第5週の木曜日 第4木曜日
2019/03/29 第5週の金曜日 第5金曜日
2019/03/30 第5週の土曜日 第5土曜日
2019/03/31 第6週の日曜日 第5日曜日
こちらも参考になります。(かなりオススメ)
www.waenavi.com
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がない場合には、
ワークシート全体で見れば2行目のセルですが、Dictionaryに格納したRangeの左上のセル(A2:ワークシート基準でのCells(2,1))を1行目、1列目とみなした相対的な行、列として指定する必要があります。従って、同じ2行目なので行を「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に1から始まるインデックスにより指定します。
下記コードでは、
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)とも)の左上のセルを1行目、1列目とした相対的指定になるようで、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のワークシートに
ちまちまと貼り付けてはサイズと位置を調整して・・・
面倒くさそうです。(私はその作業に関しては部外者なので関係ないので、他人事)
それ(棚卸)に、完璧に対応するのはとても無理だけど、
少しだけ楽(手抜き?)が出来るかもしれない処理を作ってみました。
やることは、ざっくり言えば、画像の貼り付けとリサイズの半(もう少し少ない?)自動化。
もうちょっと詳しく言えば
- 画像のあるフォルダを指定出来ること
- 画像は、指定したフォルダのサブフォルダを含めて抽出できること
- 画像の並びは、ファイル名ではなく、ファイルのフルパスで昇順とすること
- 画像を貼り付ける先頭セルを指定できること
- 画像はセル1個につき1ファイルとすること
- 貼り付けた画像は、貼り付けるセルの大きさに一致させること(オリジナルと縦横の比率が変わっても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 :画像を貼り付ける間隔(デフォルト0。省略可) ' 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
画像データはこんな感じ
実行結果
とりあえず、先頭の定数をいじれば、それなりに使えないかなぁ~
ファイルパスのソートは、一時的に追加したダミーのワークシートに配列から貼り付けて、ワークシート上でソートしてから再度配列に取り込んでます。
データ数が少ないから、セルのデータをフルスキャンしてもいいんだけど、そうしない方向でやってみました。
昔作ったクイックソートのコードを引っ張り出してきても良かったんだけど、いろいろやってみたかったので・・・
サンプルとして使用した素材は、いらすとやよりダウンロードし、使わせていただきました。
VBAのDictionaryに配列を格納して、変更してみる
どうせなので、多次元配列(3次元だけど)にしてみた。
テスト用データ
その1 配列を格納してみる
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)という形でアクセス出来るんですね。
その2 追加した配列をまるまる置き換えてみる
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
きちんと置き換わっている。
その3 ”追加した配列の要素”だけ変更出来るか?
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ワークシートに休日カレンダーを作る
休日判定を作ったので、その応用を2。
Excelのワークシートに休日を指定色にしたカレンダーを作成してみる。
(ソースコードへのリンクは下の方に・・・)
更新履歴
2019/6/13
横1列バージョンを追加しました。
仕様みたいなもの
通常(?)の1週間横並び
- 年指定(1月から12月)
- 年度指定(4月から翌年3月)
オプション
- 横1行に表示する月数を可変
- 書き込み基準位置指定可能
- 月と月の間のセル数可変(縦、横)
- 曜日と曜日の間のセル数可変
- 週と週の間のセル数可変
- 休日色(背景、文字)可変
縦
- 日付、曜日、休日名表示
- 書き込み基準位置指定可能
横
- 月、日(日付ではない)、曜日表示
- 書き込み基準位置指定可能
サンプル画像
(4月29日とか、通常の休日を非休日と設定している部分もあるので、普通の正しい(?)カレンダーとは異なるのでご注意を。)
1月から12月(3×4)
1月から12月(4×3)
1月から12月(6×2)
1月から12月(3×4、日間セルあり)
4月から3月(3×4)
縦
横
事前準備
休日判定処理クラスの休日設定(の確認)
パブリックメソッド
- createCalendarY(指定年の1月から12月までのカレンダー作成)
- createCalendarYD(指定年度の4月から3月までのカレンダー作成)
- 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