VBAで乱数を使って、意味不明（？）な文字列を生成する・・・コケヲチヰヱタトンシ
いろいろな処理をするコードを書いていると、テスト用の文字列データが欲しくなる時があります。
５個とか１０個位なら適当にキーボードから入力して作ってもいいのですが、数百とか数万とか、それ以上となるととても手入力では無理なので、どこかから探してくるか、あるいは自分で作るかということになります。
内容はどうでもいいから、とにかくデータが欲しいような時には、乱数を使って作ってしまいましょう。
基本的な事
乱数を使用するにあたって、必要なのは、以下の２つです。
Rnd関数
Randomize ステートメント
Rnd関数の使い方は、ここでは省略します。
特定の範囲の整数を生成するには以下のような計算を行います。
Randomize ランダム整数 = Int((最大値 - 最小値 + 1) * Rnd) + 最小値
最大値、最小値のいずれも整数を指定します。
負の数を指定しても大丈夫ですが
最小値<最大値
はmustです。
数字の場合
前述の式を使って取得した値をCStr関数またはFormat関数で文字列変換します。
固定桁数にし、前に０を付けたい場合には、
? Format$(123,String$(7,"0")) 0000123 ? Right$(String$(6,"0") & CStr(123),7) 0000123
こんな感じで出来ます。
注）元データの桁数が指定桁を超えた場合（上の例では７桁）、上記の２例は結果が異なりますので、ご注意ください。
アルファベットの場合
最初の式で得られるのは整数なので、これをアルファベットに変換しなければいけません。
この変換には、Chr関数を使います。
Chr関数には、文字コードを渡しますが、アルファベットの場合、ASCIIコードを指定すればOKです。
ASCIIコードは、こちらで確認できます。
大文字、小文字それぞれの範囲は、以下のようになることがわかります。
| 文字 | 文字コード |
|---|---|
| A | &H41 |
| Z | &H5A |
| a | &H61 |
| z | &h7A |
イミディエイトウィンドウで確認してみると
? Chr(&H41) A ? Chr(&H5A) Z ? Chr(&H61) a ? Chr(&H7A) z
となります。
以上を踏まえて、コードは以下のようになります。
Public Function creaeStringAlpha(ByVal lLength As Long, ByVal useUpperCase As Boolean) As String Dim iBeginCode As Integer Dim iEndCode As Integer Dim sResult As String Dim i As Long If useUpperCase Then iBeginCode = Asc("A") iEndCode = Asc("Z") Else iBeginCode = Asc("a") iEndCode = Asc("z") End If Randomize For i = 1 To lLength sResult = sResult & Chr(Int((iEndCode - iBeginCode + 1) * Rnd) + iBeginCode) Next i creaeStringAlpha = sResult End Function
useUpperCase に Trueを指定すれば大文字で、Falseを指定すれば小文字で生成します。
大小混在としたい場合には、開始コードをAsc("A")、終了コードをAsc("z")とした上で、一旦生成した文字（文字列ではないですよ）が、A～Z、a～zであるかを確認し、OKなら結合、駄目なら再度文字生成し直しというような処理にすればできます。（下記の英数混在を参照）
開始の文字コードと終了の文字コードは&H○○と直接書いてもいいのですが、あとから見て「なんだこれ？」となるのが（私の場合）普通なので、あえてコメント無しでもわかるような書き方をしています。
実行例（イミディエイトウィンドウ）
for i=1 to 5:? creaeStringAlpha(10,True):next YPMLCFTQXW WOIGQGMJCU ODWMWPUGGP UJOWHJNLLM FKPAEYZHKK for i=1 to 5:? creaeStringAlpha(10,false):next rkwqfoyvpr nyzkqsiren hygqzyzlyl djbrscyzxh fpenxaqfrd
英数混在の場合
先程ちょっと出てきた「対象外のコードを除外」をするとこんな感じで出来ます。
ASCIIコードは、
数字 < アルファベット大文字 < アルファベット小文字
なので、
最小文字コードは、数字の最小：Asc("0")
最大文字コードは、アルファベット小文字の最大：Asc("z")
を使用します。
Public Function creaeStringAlphaNum(ByVal lLength As Long) As String Dim iBeginCodeN As Integer Dim iEndCodeN As Integer Dim iBeginCodeAU As Integer Dim iEndCodeAU As Integer Dim iBeginCodeAL As Integer Dim iEndCodeAL As Integer Dim iCode As Integer Dim sResult As String Dim i As Long iBeginCodeN = Asc("0") iEndCodeN = Asc("9") iBeginCodeAU = Asc("A") iEndCodeAU = Asc("Z") iBeginCodeAL = Asc("a") iEndCodeAL = Asc("z") Randomize For i = 1 To lLength Do While True iCode = Int((iEndCodeAL - iBeginCodeN + 1) * Rnd) + iBeginCodeN Select Case iCode Case iBeginCodeN To iEndCodeN Exit Do Case iBeginCodeAU To iEndCodeAU Exit Do Case iBeginCodeAL To iEndCodeAL Exit Do End Select Loop sResult = sResult & Chr(iCode) Next i creaeStringAlphaNum = sResult End Function
実行例（イミディエイトウィンドウ）
for i=1 to 5:? creaeStringAlphaNum(20):next sC2TMIaUKFpJgxGLCjV8 UDnhkqy3OOG6Lk4QdwZC 5AldQ84Ug33RKwTtbIyj W1Wd1iifx2qrJ66IxNp9 Lj31yD74w0In3i8zqEn2
ひらがなの場合
基本的には、アルファベットの時と同じですが、ひらがなの場合文字コードがASCIIコードではなく、ユニコードを使用することになるのでChr関数がChrW関数に、Asc関数がAscW関数を使用することになります。
ユニコードのひらがなは、
こちらを見てください。
VBAでは、一部の文字（&H3094以降の一部）が使用できないため、それらの文字は除外する必要があります。
コードは、
Public Function creaeStringKana(ByVal lLength As Long) As String Dim iBeginCode As Integer Dim iEndCode As Integer Dim sResult As String Dim i As Long '厳密には違うが、VBAで対応できないので、対応可能範囲に限定する iBeginCode = AscW("ぁ") iEndCode = AscW("ん") Randomize For i = 1 To lLength sResult = sResult & ChrW(Int((iEndCode - iBeginCode + 1) * Rnd) + iBeginCode) Next i creaeStringKana = sResult End Function
実行例（イミディエイトウィンドウ）
for i=1 to 5:? creaeStringKana(10):next ふだわんぇよずぽへゎ ろすいらうぱこだぶよ ゎゆめぐほばぽきぴぺ わたのぞらぼづきそあ をむゑろもべぬぶぼよ
カタカナの場合
ひらがなの時と同じですね。コードの範囲が変わるだけです。
文字コードはこちらになります。
コードは、
Public Function creaeStringKatakana(ByVal lLength As Long) As String Dim iBeginCode As Integer Dim iEndCode As Integer Dim sResult As String Dim i As Long '厳密には違うが、VBAで対応できないので、対応可能範囲に限定する iBeginCode = AscW("ァ") iEndCode = AscW("ヶ") Randomize For i = 1 To lLength sResult = sResult & ChrW(Int((iEndCode - iBeginCode + 1) * Rnd) + iBeginCode) Next i creaeStringKatakana = sResult End Function
実行例（イミディエイトウィンドウ）
for i=1 to 5:? creaeStringKatakana(10):next ヶェコゼヂクズザシヤ ゥゼゼキピォンナイベ ヲヒユテビゲネモツノ ズェャヨベリコデグダ コケヲチヰヱタトンシ
"ヰヱ"なんて誰が使うんだよっ！ orz
2019/4/1追記
不連続の多い文字群の場合、キーコードを使用しないで、予め使用可能な文字を配列に１文字ずつ突っ込んで全部結合してから、rndで発生させた乱数で配列のインデックスを指定してもいいのかもしれない全部結合してから、rndで発生させた乱数を使って、midで抜き出してもいいのかもしれない。
これなら、半角、全角混在でも簡単（？）に出来そう。
2019/4/2追記
昨日のアイデアを元に、簡単なパスワード生成関数を作ってみた。
Public Function createPassword(ByVal lLength As Long) As String Const USABLE_CHARS As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!#$%(){}" Dim lPos As Long Dim sPassword As String Dim i As Long Randomize For i = 1 To lLength lPos = Int(Len(USABLE_CHARS) * Rnd) + 1 sPassword = sPassword & Mid$(USABLE_CHARS, lPos, 1) Next i createPassword = sPassword End Function
実行結果
for i=1 to 15:? createPassword(10):next lG%wfn9kA7 #VkE0X!xN} pAFE6hQHhK }EhwtPoBEE nZZeeiDYC4 Ivrs96dxq% 0)NsDNg#8v f8JG3rd07o hamu)ojZXd Y%Zwlxh4VT dCgkztKKFK VU6(y!xdfB ba!2Pu6bs4 Wi4ei!Gbc) w{oG{ZZ(ov
指定日が、月内で第何度目の何曜日かを求める（VBA）
最近、表題の処理を２件ほど、はてなブログで見かけた。
いずれの処理も、月始めから指定日までループ処理をしていたが、この手の処理は１週間（７日）の周期性があるので、それを利用してループ処理なしで求めてみた。
thom.hateblo.jp
b004nws862zx.hatenablog.com
抑えておくべきこと
第１の日曜日から土曜日は、毎月１日から７日にある。
第２の日曜日から土曜日は、毎月８日から１５日にある。
以下同様
従って、
| 日 | 週 |
|---|---|
| １～７ | １ |
| ８～１４ | ２ |
| １５～２１ | ３ |
| ２２～２８ | ４ |
| ２９～３１ | ５ |
となる。
７日の周期で、週が１加算されていくので、７で割った商を使えばよい。
ただし、そのまま日を７で割ってしまっては求めたい値（週）は得られない。
7で割って商が1となる整数は、7から13である。そこで1から7を7から13に補正するため、６を加算した上で、７で割ることで目的の値が得られる。
これは商が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
第何週目の何曜日なのかの場合
基本は上の例と同じ。
違うのは、日に対する補正値。
上の例では、単純に６を加算すればよかったが、この場合には、第１土曜日が１３（７で割って商が１になる最大の整数）になるようにすればよい。
しかし、第１土曜日が何日かによって補正値が変わってくる。
| １日の曜日 | 第１土曜日の日 | 第１土曜日の日を１３にするために必要な値 |
|---|---|---|
| 日 | ７ | ６ |
| 月 | ６ | ７ |
| 火 | ５ | ８ |
| 水 | ４ | ９ |
| 木 | ３ | １０ |
| 金 | ２ | １１ |
| 土 | １ | １２ |
となることから、
第１土曜日の日＋５＋Weekday(１日の日付)
とすることで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 '指定日の月の１日 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がない場合には、
ワークシート全体で見れば２行目のセルですが、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)を書き換える事は出来ないみたい。
エラーは出ずに処理は終了するんだけどねぇ・・・
読み取り専用のような感じ。
やっぱり一旦データを変数に取り出して、編集後に再度設定するしかないのかもしれない。
