ジャグ配列の中身をすべてを、イミディエイトウィンドウに書き出す。
ジャグ配列とは…
要素数の異なる配列のことです。
（例）
配列(２)
配列(0)(0),(0)(1)
配列(1)(0),(1)(1),(1)(2)
配列(2)(0),(2)(1),(2)(2),(2)(3)
配列(0)は２つの要素を持つ。
配列(1)は３つの要素を持つ。
配列(2)は４つの要素を持つ。
このように、要素数の異なる配列のことをジャグ配列と呼びます。
VBAでジャグ配列の作り方
Sub jag配列作成() Dim jagarr() As Variant jagarr = Array(Array(1, 2), Array(3, 4, 5, 6), Array(7, 8, 9, 10, 11)) End Sub
下の画像の通りジャグ配列ができる。
ジャグ配列の中身すべてをイミディエイトウィンドウに書き出す。
Sub jag配列_要素全てを書出し() Dim jagarr: jagarr = Array(Array(1, 2), Array(3, 4, 5, 6), Array(7, 8, 9, 10, 11)) jagValue = jagarr(0)(0) 'jag配列の最小値、最大値をイミディエイトウィンドウに書き出す Debug.Print "jag配列数 = " & LBound(jagarr) Debug.Print "jag配列数 = " & UBound(jagarr) 'jag配列の要素をイミディエイトウィンドウに書き出す For jaghi = LBound(jagarr) To UBound(jagarr) For jaghihi = LBound(jagarr(jaghi)) To UBound(jagarr(jaghi)) Debug.Print jagarr(jaghi)(jaghihi) Next Next End Sub
下の画像の通りジャグ配列の要素をイミディエイトウィンドウに書き出す。
LBound、UBoundを使って配列のそれぞれの要素数を調べ、それをループ数とすることですべての要素をイミディエイトウィンドウに書き出すことができます。
なお、ジャグ配列の活用方法はわかりません(;^ω^)
備忘録でした(^^)/~~~
複数の改行するスマートなコード
結論
Sub 改行() '普通の書き方 MsgBox "かず" & vbCrLf & vbCrLf & "やん" 'スマートな書き方 MsgBox "かず" & String(2, vbCrLf) & "やん" End Sub
処理結果は同じ
「& vbCrLf & vbCrLf & 」ではなく、「& String(2, vbCrLf) &」と記述することにより、２回改行します。
なぜスマートかというと、５回改行したい場合、「& String(5, vbCrLf) &」と書けば済むからです。
備忘録でした(^^)/~~~
VBA100本ノック 39本目：数値リストの統合（マージ）
１ 今回のお題
A列とB列の数値を統合（マージ）しユニーク化してC列に出力します。
・A列、B列ともに行数は不定
・列内では数値は昇順になっています。
・列内では重複していないが、A列とB列では重複します。
・C列へは重複しない数値として昇順に出力してください。
※画像を参考に。
２ 今回のお題の意図
同じ列に重複はない。別の列には重複する数字がある。複数の列から重複しない数字を列Cに書き出す。
３ 回答
私の最初の回答
Sub ノック39本目_1() Dim hi() As Variant Dim myCollection As New Collection Dim ws As Worksheet: Set ws = Worksheets("sheet1") '最終行の取得 rowLastLineA = ws.Cells(Rows.Count, 1).End(xlUp).Row rowLastLineB = ws.Cells(Rows.Count, 2).End(xlUp).Row ReDim hi(1 To rowLastLineA) For k = 1 To rowLastLineA hi(k) = ws.Cells(k, 1) Next ReDim Preserve hi(1 To rowLastLineA + rowLastLineB) For i = 1 To rowLastLineB hi(rowLastLineA + i) = ws.Cells(i, 2) Next On Error Resume Next '重複の代入エラーを無視 For j = 1 To rowLastLineA + rowLastLineB myCollection.Add hi(j), CStr(hi(j)) Next On Error GoTo 0 'エラー無視の解除 '列Cへ転記 For k = 1 To myCollection.Count ws.Cells(k, 3) = myCollection(k) Next '列Cを並べ替え Range("C1:C11").Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlNo End Sub
処理手順
１ A、B列の数字を配列に入れる。
２ Collectionに重複しない数字を取得する。
３ 列Cに転記する。
４ 並べ替える。
ポイントとしてはCollection．Add処理の、Keyは文字列で代入しないと重複してItemを追加（Add）してしまいます。
「myCollection.Add hi(j), CStr(hi(j))」（Add Item,Key）のKeyを、Cstr関数で文字列に変換する必要があります。
これは、パラメータがItemがObjectに対し、KeyはStringのためであると思われます。
４ 感想
CollectionはItemが重複するObjectを代入することができないと思っていたのですが、実際はKeyが重複不可でした。
かなり重要な勘違いをしていました(;^ω^)。数字のユニーク化でも、KeyをCstr関数で文字列として扱えば可能となります。
ではでは、この辺で(^^)/~~~
VBA100本ノック 38本目：1シートを複数シートに振り分け
この記事から得るもの
日付データから、祝日、平日、休日の判断ができるようになる。
書込み処理のサブルーチン化のやり方が分かる。
１ 今回のお題
「売上」シートのA列に日付が昇順で入っています。
土日祝と平日に分けて別シートに出力してください。
・「売上」シートの列数は不定。
・「土日祝」「平日」シートは既存です。
・祝日は「祝日」シートのA列にあります。
※セルの書式の扱いは任意
２ 今回のお題の意図
Weekday関数を使って曜日を取得し、条件分岐する。
Countif関数を使って祝日の、条件分岐をする。
３ 回答
私の最初の回答
Sub ノック38本目_1() Dim wirteWeekdays_IX As Long: wirteWeekdays_IX = 1 '平日書込み用 Dim writeHolidays_IX As Long: writeHolidays_IX = 1 '休日書込み用 Dim wsEarnings As Worksheet: Set wsEarnings = Worksheets("売上") Dim wswriteHolidays As Worksheet: Set wswriteHolidays = Worksheets("土日祝") Dim wswriteWeekdays As Worksheet: Set wswriteWeekdays = Worksheets("平日") Dim wsPublicHoliday As Worksheet: Set wsPublicHoliday = Worksheets("祝日") Dim endFlg As Boolean For i = 2 To wsEarnings.Range("A1").CurrentRegion.Rows.Count mydate = wsEarnings.Cells(i, 1): endFlg = False '祝日の処理 For j = 1 To wsPublicHoliday.Range("A1").CurrentRegion.Rows.Count If mydate = wsPublicHoliday.Cells(j, 1) Then '祝日書込み処理 If writeHolidays_IX = 1 Then For k = 1 To wsEarnings.Range("A1").CurrentRegion.Columns.Count wswriteHolidays.Cells(writeHolidays_IX, k) = wsEarnings.Cells(1, k) Next End If writeHolidays_IX = writeHolidays_IX + 1 '書込み変数インクリメント For k = 1 To wsEarnings.Range("A1").CurrentRegion.Columns.Count wswriteHolidays.Cells(writeHolidays_IX, k) = wsEarnings.Cells(i, k) Next endFlg = True End If Next '平日、土日の処理 If endFlg = False Then If Weekday(mydate) = 7 Or Weekday(mydate) = 1 Then '休日書込み処理 If writeHolidays_IX = 1 Then For k = 1 To wsEarnings.Range("A1").CurrentRegion.Columns.Count wswriteHolidays.Cells(writeHolidays_IX, k) = wsEarnings.Cells(1, k) Next End If writeHolidays_IX = writeHolidays_IX + 1 '書込み変数インクリメント For k = 1 To wsEarnings.Range("A1").CurrentRegion.Columns.Count wswriteHolidays.Cells(writeHolidays_IX, k) = wsEarnings.Cells(i, k) Next Else '平日書込み処理 If wirteWeekdays_IX = 1 Then For k = 1 To wsEarnings.Range("A1").CurrentRegion.Columns.Count wswriteWeekdays.Cells(wirteWeekdays_IX, k) = wsEarnings.Cells(1, k) Next End If wirteWeekdays_IX = wirteWeekdays_IX + 1 '書込み変数インクリメント For k = 1 To wsEarnings.Range("A1").CurrentRegion.Columns.Count wswriteWeekdays.Cells(wirteWeekdays_IX, k) = wsEarnings.Cells(i, k) Next End If End If Next End Sub
まずは、平日Sheet、土日祝日Sheet書込み用変数を１として宣言します。
また、各Sheetをオブジェクト変数にSetします。
メイン処理は、まず祝日がどうかを変数mydateに売上Sheetの日付を代入し、祝日Sheetのデータをループ処理して探す。
次に、祝日で無い場合は、Weekday関数を使って土日か判断をする。土日であれば、土日祝日Sheet書込みし、それ以外（平日）なら平日Sheetに書込みます。
これをTwitterに投稿したところ、サイト管理者から以下のツッコミがありました。
「祝日の判定をループせずに出来るとより良いと思います。」
ループ処理せずに判定できる方法あるの？？と思いました。しかし、サイトの回答を見てみるとCountifを使っていることに気づきました。
そうか、処理対象の日付が祝日Sheetないにあれば、Countifが戻り値が０以上になる！そこで判断すればいいのかということに気づきました。
また、書込み処理部分が長くなってしまうので、書込み処理はサブルーチン化しました。
私の最終回答
'モジュールレベルの変数宣言 Dim wirteWeekdays_IX As Long: Dim writeHolidays_IX As Long Dim wsEarnings As Worksheet: Dim wswriteHolidays As Worksheet Dim wswriteWeekdays As Worksheet: Dim wsPublicHoliday As Worksheet Dim i As Long: Dim endFlg As Boolean: Dim mydate As Date Sub ノック38本目_2() wirteWeekdays_IX = 1 '平日書込み用 writeHolidays_IX = 1 '休日書込み用 Set wsEarnings = Worksheets("売上"): Set wswriteHolidays = Worksheets("土日祝") Set wswriteWeekdays = Worksheets("平日"): Set wsPublicHoliday = Worksheets("祝日") For i = 2 To wsEarnings.Range("A1").CurrentRegion.Rows.Count mydate = wsEarnings.Cells(i, 1): endFlg = False '祝日の処理 If WorksheetFunction.CountIf(wsPublicHoliday.Columns(1), wsEarnings.Cells(i, 1)) > 0 Then '祝日書込み処理 If writeHolidays_IX = 1 Then For k = 1 To wsEarnings.Range("A1").CurrentRegion.Columns.Count wswriteHolidays.Cells(writeHolidays_IX, k) = wsEarnings.Cells(1, k) Next End If writeHolidays_IX = writeHolidays_IX + 1 '書込み変数インクリメント For k = 1 To wsEarnings.Range("A1").CurrentRegion.Columns.Count wswriteHolidays.Cells(writeHolidays_IX, k) = wsEarnings.Cells(i, k) Next endFlg = True End If '平日、土日の処理 If endFlg = False Then Call 書込み処理 End If Next End Sub
サブルーチン、書込み処理
Private Sub 書込み処理() If Weekday(mydate) = 7 Or Weekday(mydate) = 1 Then '休日書込み処理 If writeHolidays_IX = 1 Then For k = 1 To wsEarnings.Range("A1").CurrentRegion.Columns.Count wswriteHolidays.Cells(writeHolidays_IX, k) = wsEarnings.Cells(1, k) Next End If writeHolidays_IX = writeHolidays_IX + 1 '書込み変数インクリメント For k = 1 To wsEarnings.Range("A1").CurrentRegion.Columns.Count wswriteHolidays.Cells(writeHolidays_IX, k) = wsEarnings.Cells(i, k) Next Else '平日書込み処理 If wirteWeekdays_IX = 1 Then For k = 1 To wsEarnings.Range("A1").CurrentRegion.Columns.Count wswriteWeekdays.Cells(wirteWeekdays_IX, k) = wsEarnings.Cells(1, k) Next End If wirteWeekdays_IX = wirteWeekdays_IX + 1 '書込み変数インクリメント For k = 1 To wsEarnings.Range("A1").CurrentRegion.Columns.Count wswriteWeekdays.Cells(wirteWeekdays_IX, k) = wsEarnings.Cells(i, k) Next End If End Sub
修正点は２点です。
１点目は、祝日の判定処理をCountifに変更しました。
２点目は、休日、平日の書き込み処理をサブルーチン化しました。サブルーチン化すると、処理がサブルーチンのコードに移った時に、プロシージャレベルの変数の値は破棄されるため、書込み用の変数、Sheet用の変数、endFlgはモジュールレベルの変数としました。
ここまでやるなら、祝日の処理も書込み処理のサブルーチンの中に入れれば？？と思いましたが、時間がある時に修正したいと思います。
やはり、サブルーチン化するとメイン処理がすっきりと見えます。モジュールレベルの変数をどれにするかが悩ましいところではありますが(;^ω^)。
４ 感想
コードの部品化（サブルーチン化）は、可読性をあげる、保守しやすくするために必要だと思っていますが、なかなか手を出せずにいたので今回で少しレベルが上がりました。もっと部品化して、可読性の高いコードを書いていこうと思います。
ではでは、この辺で(^^)/~~~
５ 英語の勉強
売上：Earnings
平日：Weekdays
休日：Holiday
祝日：Public Holiday
（土日祝Sheetは「Holidays」と造語を使っております。）
VBA100本ノック 32本目：Excel終了とテキストファイル出力
この記事から得るもの
１ 今回のお題
開かれているブック全てを上書き保存して、Excelアプリも終了させてください。
履歴として、保存したブックのパスをテキストファィルに出力してください。
テキストファイルはマクロブックと同一フォルダに以下の名称で出力(SJIS)してください。
log_yyyymmddhhmmss.txt（フルパス出力してください。）
２ 今回のお題の意図
エクセルで開かれている全ブックを上書き保存して、テキストにエクセルのフルパスを書き出すことにより、どのエクセルファイルを保存したかが分かるようにする。
３ 回答
私の最初の回答
Sub ノック32本目_1() 'FSO宣言 Dim fso As Object: Set fso = CreateObject("scripting.filesystemobject") Dim fsoText As Object Set fsoText = fso.CreateTextFile(ThisWorkbook.Path & "\32本目\log_" & Format(Now, "yyyymmddhhmmss") & ".txt", True) 'ファイルPathを取得 Set myfiles = fso.getfolder(ThisWorkbook.Path & "\32本目").Files For Each file In myfiles 'ファイルかどうか判断してlog保存先Pathを取得する If file.Name Like "log_*.txt" Then logText = file.Path Exit For End If Next fsoText.Close 'テキストファイルを閉じる 'ファイルを開いて書き込む Open logText For Output As #1 myBookPath = ThisWorkbook.Path & "\" & ThisWorkbook.Name '自Book以外を閉じる処理 For i = Workbooks.Count To 1 Step -1 otherBookPath = Workbooks(i).Path & "\" & Workbooks(i).Name If myBookPath <> otherBookPath Then Print #1, otherBookPath: Workbooks(i).Close 'テキストに書込み、ファイルを閉じる End If Next 'テキストに書込み、自Bookを保存 Print #1, myBookPath: ThisWorkbook.Save Close #1 'エクセルを終了する Application.DisplayAlerts = False Application.Quit End Sub
一応お題通りの処理はできていますが、fso.CreateTextFileでログ書き込み先のテキストファイルを作って、いったん閉じて「Open For Output As」で開きなおしているのがナンセンスです。
このお題での重要な気づきは、「Open ファイル名 For Output As」の時に、ファイル名が存在しなければ新規に作ってくれます。
つまりfso.CreateTextFileは必要ないのです。
サイト管理者の回答
Sub VBA100_32_01() ThisWorkbook.Save Dim ymdhms As String ymdhms = Format(Now(), "yyyymmddhhmmss") Open ThisWorkbook.Path & "\log_" & ymdhms & ".txt" For Output As #1 Dim wb As Workbook For Each wb In Workbooks wb.Save Print #1, wb.FullName Next Close #1 Application.Quit End Sub
実際動かしてみるとわかるのですが、「Open ThisWorkbook.Path & "\log_" & ymdhms & ".txt" For Output As #1」を実行したときに、Pathフォルダにテキストファイルが作成されます。これは大きな気づきでした。FSOいらんやん！！
４ 感想
「Open ファイル名 For Output As」の時に、ファイル名が存在しなければ新規に作ってくれる。
大きな収穫でした。
ではでは、この辺で(^^)/~~~
VBA100本ノック 33本目：マクロ記録の改修
この記事から得るもの
１ 今回のお題
「このVBAはマクロの記録から作ったのですが、件数の数値を変更してから実行しなければならず、データ件数も多くて何分も時間がかかりとても困っています。なんとかしてもらえないでしょうか?」
こう頼まれました。VBAを書いて対応してあげましょう。
Sub ノック33_ソース() Sheets("データ").Select For i = 2 To 3500 DoEvents Range("D" & i).Select ActiveCell.FormulaR1C1 = _ "=IFERROR(VLOOKUP(RC[-2],マスタ!C[-3]:C[-1],2,FALSE),"""")" Range("E" & i).Select ActiveCell.FormulaR1C1 = _ "=IFERROR(VLOOKUP(RC[-3],マスタ!C[-4]:C[-2],3,FALSE),"""")" Range("F" & i).Select ActiveCell.FormulaR1C1 = _ "=RC[-1]*RC[-3]" Range("D" & i & ":F" & i).Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Next Range("A1").Select End Sub
２ 今回のお題の意図
処理速度をあげる処理を追加。必要な分だけ処理する。
３ 回答
記録マクロのソースコードを動かしてみるとわかるのですが、「For i = 2 To 3500」とループ回数を決めてしまっています。そのため、データが入力されている分だけ処理をする。加えて、処理速度をあげるコードを追加してあげます。
私の回答
Sub ノック33_1() Dim ws As Worksheet: Set ws = Worksheets("データ") '処理速度を上げるやつ設定 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Sheets("データ").Select For i = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row '最終行の取得 Range("D" & i).Select ActiveCell.FormulaR1C1 = _ "=IFERROR(VLOOKUP(RC[-2],マスタ!C[-3]:C[-1],2,FALSE),"""")" Range("E" & i).Select ActiveCell.FormulaR1C1 = _ "=IFERROR(VLOOKUP(RC[-3],マスタ!C[-4]:C[-2],3,FALSE),"""")" Range("F" & i).Select ActiveCell.FormulaR1C1 = _ "=RC[-1]*RC[-3]" Range("D" & i & ":F" & i).Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Next Range("A1").Select '処理速度を上げるやつ設定終了 Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub
１ 処理速度を上げる処理
画像描写更新を止める。再計算処理を止める。
２ データの最終行を取得する。
これだけですね。ざっくりした質問には、ざっくりした対応です。
ではでは、この辺で(^^)/~~~
ＳＱＬ文で他のBookのデータを更新する。
１ 閲覧対象者
データを更新するエクセルBookと、データを蓄積するBookを別けたい方（いわゆるDBファーストです）。
更新用Bookからベタ打ちのSQL文を発行するだけなので、ADO接続、SQL文の書き方がよくわからない初心者の方。
２ 得られる効果
１） 更新用Bookとデータを蓄積するBookを別けることでデータの管理が容易となる。
２） ADO接続の方法が分かる。
３） 簡単なSQL文（Update）の使用方法がわかる。
３ 設計
以下の画像のように、Bookを２つ準備します。
DB.xlsmの中身
「氏名」、「カード番号」の２行だけです。クレジットカードの番号管理的なイメージで！
使い方
参照設定
更新用BookにADO接続を使用するために、以下の画像の蛍光線部の参照設定をします。
DB更新用.xlsmを開きます。このBookの中に以下のコードを記述しています。
Const cnsProvider = "Microsoft.ACE.OLEDB.12.0" Const cnsExprop = "Extended properties" Const cnsExcel = "Excel 12.0" Const cnsDBname = "DB.xlsm" Const cnsYen = "/" Sub Update_SQL() Dim upSQL As String 'Connecionの作成 Set DBcon = New ADODB.Connection With DBcon .Provider = cnsProvider .Properties(cnsExprop) = cnsExcel .Open ThisWorkbook.Path & "\" & cnsDBname End With 'SQL文作成 (セルに付けた名前がテーブルとなる) upSQL = "update [name$] SET 氏名 = '神田 えの' where カード番号 = '2'" 'DBの更新 DBcon.Execute (upSQL) '終了。オブジェクトの参照破棄 DBcon.Close: Set DBcon = Nothing End Sub
内容としては、カード番号「２」の氏名を「神田 えの」に変更します。
Update_SQLの実行結果は以下の画像の通り↓↓
更新したいDB.xlsmのPathは「ThisWorkbook.Path & "\" & cnsDBname」で指定しています。
ファイル名の変更をしたい場合は、「Const cnsDBname = "DB.xlsm"」を別のBook名に変更すればＯＫです。
ほかのフォルダを指定したい場合は、「ThisWorkbook.Path」ではなく、指定のファルダPATHを直指定してください。
最初のConstの部分でADO接続の設定をしていますのでそのままコピペでＯＫです。ここはあまり深く考えなくてよいです。
更新用ＳＱＬ文は変数「upSQL 」に作っています。
upSQL = "update [name$] SET 氏名 = '神田 えの' where カード番号 = '2'"
このＳＱＬ文を動作させるためには、DB.xlsmのSheet名を「name」にしておく必要があります。
「DBcon.Execute (upSQL)」でSQL文を実行します。これで「神田 えの」に変更されます。
４ 感想
Update文を作成でエラーが出ていて２時間も格闘していました(;^ω^)。原因は、「氏名 =」この空白部分が全角空白でエラーになってました。
今回は、SQL文を直指定していますので実用性はありません。SQL文を条件で作成して更新すると実用的になりますね。
その辺は、次回の記事を作ります。
１つわからなかったことがありました。私はExcel2019で作成しています。なので、Versionは「Excel 16.0」になるのですが、「Const cnsExcel = "Excel 12.0"」の12.0を16.0にするとエラーになります。ここだけなぜかわかりませんでした。わかる方は教えていただけると喜びますm(_ _"m)
｛Twitterで教えていただいた方によれば、エクセルのversionではなく検索エンジンのversionらしいです。自分でも調べてみますm(_ _"m)｝
ではでは、この辺で(^^)/~~~
