エクセルで楽々校務

学校現場で使えるエクセルファイルや小技の紹介をしています。掘り出し物があるかもしれません。あと、今までの実践での疑問点もつぶやきます。

【VBA】VBAで配列を、高速に書き出す方法

新年おめでとうございます。

お久しぶりです。今回は、配列を高速に書き出す方法の備忘録です。

e出席簿の改良で難点がありました。

休日に赤縦線を引いたり、欠席や出席停止児童数の計算ができるのは当たり前。

私がこだわっているのは、「備考欄への欠席理由一括記入」の自動化です。

月別のシートではこれができますが、

指導要録への記入の時に、一覧が欲しいです。

個人別に、欠席・停止・忌引き理由をフィルターで配列に格納することはできました。

しかし、この配列を書き出す時に思いのほか時間がかかりました。

フィルター→配列格納=数秒

配列をセルに書き出すのに1~2分かかってしまいました。

-------------------------------

まず、【遅いコード】です。

配列tmpを現在シートのJ4:J43セルに書き出すコードです。

Dim tmp(0 to 39)

(フィルター→配列格納は割愛します。)

k=0

For each rng in range("J4:J43")

  rng.value=tmp(k)

  k=k+1

next

セル範囲をループする一般的な書き出し方法です。For eachでも1~2分かかってしまいました。

 

次に【速いコード】です。

Dim tmp(0 to 39)

Dim my_array

(フィルター→配列格納は割愛します。)

k = 0
my_array = Range("J4:J43")

'配列を格納
For i = 1 To UBound(my_array)
    For j = 1 To UBound(my_array, 2) '''''''★この2は配列上の2次元
        my_array(i, j) = tmp(k)
        k = k + 1
    Next
Next

'書き出し
Range("J4:J43") = my_array

-----------------------------------

ポイントは、書き出し範囲をmy_array配列に格納して、その配列上にtmp(k)配列を書き込み、

それを一気にセル範囲に書き出すというところです。

普段は使わないにしても、書き出しに時間がかかる場合は、飛躍的に書き出し速度が上がります。1~2分かかっていたのが、5秒以内で書き出せました。

 

備忘録でした。

 

では、また

 

 

【VBA】dictionaryのkeyに、一意の連番を使用して高速に値転記する方法

お久しぶりです。

成績処理で忙しい季節ですね。

さて、今回は、dictionaryについてです。

ある程度VBAを使いこなせてくると、値を一気に転記できるdictionaryを

使いたくなりますね。

一般には、一意のkeyに紐づけされたitemを転記できるわけですが、

1列(1次元配列)だけを転記する時は、keyに連番を入れるだけで処理はできます。

例えば、通信簿の所見集を作るために、

40人×3クラス×6学年=720人分のデータを集めた所見集を作りたい場合などに

利用できると思います。

転記回数は少ない方が高速に処理できるので、今回は、

10行飛ばしのデータを全部dictionaryに入れて、全部を一気に書き出すというコードを書いてみました。

--------------------------------------

【コード】

Option Explicit

Sub 所見読み込みdictionary()


Dim i, k As Integer
Dim myDic As Object

 


Application.ScreenUpdating = False

Set myDic = CreateObject("Scripting.Dictionary")

'myDicにKeyItemを格納する

i = 0
For k = 7 To 397 Step 10'''10行飛ばし
 myDic.Add i, Workbook("aaa").Sheets("aaa").Cells(k, "D").Value

'''''''''★iをキーのカウントとして使用
 i = i + 1
Next k

 

''''''★Itemを一括で書き出す

For i = 0 To myDic.Count - 1
 ThisWorkbook.Sheets("bbb").Cells(i + 2, "C").Value = myDic.Item(i)
Next i

Set myDic = Nothing

''''''''''''''''''''''''''''''''''''''''
Application.ScreenUpdating = True

End Sub

------------------------------------------

i(連番)を使うだけで、dictionary処理が書けちゃいます。

処理時間は、最後の書き出し回数が少ない方が速いですね。

実務では、これを複数ブック読み込みにして、約1000人分を

一気に処理できるようにしています。

とにかく、このコードが学校の事務処理でdictionaryを使う時の基本みたいな感じがします。

 

あと少しでゴールですね。お互い頑張りましょう!

 

では、また(^^)/

 

【VBA】異なるブックからリンク貼り付けのツボは「.Activate」

出席簿の備考欄も自動入力できるようにして、電子出席簿はほぼ完成したのですが、勤務校では保健日誌ともデータ照合して数字に根拠を持たせるようにしています。

「出欠整合性チェックブック」を作って、各クラスの出席簿と保健日誌の出欠状況数のリンクをコピーしてきて、両者を比較できるようにしています。

マクロでこの処理をする時、ネットでコードを探して組んだのですが、うまくいきませんでした。結論は、「シートをアクティブにしながら処理をしないとリンク貼り付けは正確にできない」ということです。

 

f:id:exeladmin:20210111021323p:plain

後で説明するコードを実行するとブック選択ダイアログが開きます。

単数ブック選択にしているので、ブックを1つ指定して「開く」をクリックすると、

リンク貼り付けが自動でできます。

で、リンク元は1入力~12入力というシート名で、それぞれのセルD224~AH279の範囲を、現ブックの1~12シートの、セルD60以降にリンク貼り付けするために書いたコードが次です。

----------------------------------------------------

Sub 異なるブックからリンク貼り付け()

Dim cpm,btn As Variant
Dim i, n As Integer
Dim wb As Variant
Dim sh, ash As Worksheet

ChDir ThisWorkbook.Path '★現在フォルダーを起点フォルダーに設定

cpm = Application.GetOpenFilename(FileFilter:="Microsoft Excelブック,*", _
Title:="読み込むブックを1つ選択してください!", MultiSelect:=False) '単数ブック読み込み

Set ash = ActiveSheet '現シートをセットしておく

btn = cpm 'キャンセル判定に使用

If btn = False Then

  MsgBox "処理を中止しました。"
  ash.Activate
  Range("H8").Select
  Exit Sub
Else

  On Error Resume Next '''''必要
  Application.DisplayAlerts = False '警告停止
  Application.ScreenUpdating = False

Workbooks.Open cpm '読込ファイル
Set wb = Workbooks.Open(cpm) ''''''''''''''''''''''''★読込ファイルをオブジェクトセット

n = 60 '転記先行番号
For i = 1 To 12 'シート名は月数字
'リンク転記元
wb.Sheets(CStr(i) & "入力").Activate '''''''''''''''''''★読込シートをアクティベート★
Sheets(CStr(i) & "入力").Range("D224:AH279").Copy

ThisWorkbook.Sheets(CStr(i)).Activate ''''''''''''''★現シートをアクティベート
ActiveSheet.Protect userinterfaceonly:=True ''''''''''''''★現シートをマクロ操作OKで保護
ActiveSheet.Cells(n, "D").Select
ActiveSheet.Paste Link:=True
Application.CutCopyMode = False
ActiveSheet.DisplayPageBreaks = False ''''''''''''''★改ページ非表示★
ActiveSheet.Cells(1, "A").Select''''''''''''A1セルを選択して処理を終わる
Next

wb.Close (False) ''''''''''コピー元閉じる

Application.DisplayAlerts = True '警告復旧
Application.ScreenUpdating = True

MsgBox "処理完了!"
ash.Activate
Range("H8").Select

End If

End Sub

------------------------------------------

今回は単数ブックからリンク貼り付けする例ですが、

せっかくなら、複数ブック読み込みにして希望のブックを全部、見かけ上開かずに読み込んで自動処理したいですよね。

その時には、ブックを切り替えていくので、文字コードのように、それぞれをActivateして切り替えていかないとうまくリンク貼り付けできませんでした。

備忘録として書いておきますが、もし異なるブックからリンクを引っ張ってきたいんだけどうまくいかない方がおられましたら参考にしてみてください。

 

だいぶ寒さが緩んできました。連休明けはちょっとは暖かいかな・・・。

では、また!