2021年12月 プログラムの話 その1 | 初めての犬飼い日記
Amebaホームピグアメブロ
芸能人ブログ人気ブログ
新規登録
ログイン

初めての犬飼い日記

シゲという名前の保護犬を飼うことになったアラフォーオッサンの記録です

2021年12月 プログラムの話 その1

 

毎回、困る度にネットで検索するのが面倒くさいので、よく使う機能を備忘録としてメモしておきます。

 

今回は EXCEL VBA で使えるメソッドです。

 

まずは、2次元配列の内容を保持したままで、1次元目の要素数を変更するメソッド。

 

通常、2次元配列の内容を保持したままで要素数を変更できるのは2次元目のみで、1次元目の要素数を変更する際は配列の内容が完全に消えてしまうという EXCEL VBA の仕様がありまして…。

 

そうした理由はなんとなく分かるのだけれど、とても不便なので Google で検索してみたところ、似たようなことで困っていた人が行列を入れ替える Transpose という関数を利用する方法でこの機能を実現しているのを見つけたのです。

 

ただ、そのままではエラーが発生する可能性があったので、サイズ変更に関する部分を少しアレンジしまして、それでも意図せずエラーが発生した場合の為にエラー処理を追加しています。エラー時には要素数ゼロの配列を返すようにしています。

 

 

2次元配列の1次元目の要素数を変更する
' 2次元配列の1次元目を増やすモジュール
Public Function RedimPreserveArray(ByVal arr As Variant, ByVal size As Long)
    
On Error GoTo ERROR_EXIT
    
    Dim buf() As Variant
    buf = WorksheetFunction.Transpose(arr)
    ReDim Preserve buf(LBound(buf, 1) To UBound(buf, 1), LBound(buf, 2) To LBound(buf, 2) + size - 1)
    RedimPreserveArray = WorksheetFunction.Transpose(buf)
    Exit Function
    
ERROR_EXIT:
    
    RedimPreserveArray = VBA.Array()
    
End Function

 

 

 

次は EXCEL をデータベースとして使っている人だと、テーブルを多用していると思うのですが、そのテーブルのレコードを全削除するメソッドです。

 

最速の処理を求めるのであれば、ListObject.DataBodyRange.Clear を使うべきだというのは分かっているのですが、それだと同じシート内に別のテーブルが存在した場合に、行削除を実行してくれずにセルの内容だけがEmptyになり、ListObject に空のレコードがそのまま残ってしまうのです。

 

なので、ListObject.DataBodyRange.Delete を使用しているのは 『 敢えて 』 なのです。

 

 

テーブルの全レコードを削除する
Public Sub ClearTable(ByVal sheetName As String, ByVal tableName As String)
	Dim sheet As Worksheet
    Dim table As ListObject

On Error GoTo CLEAN_UP

	' パラメータで指定された名前のワークシートを取得
	Set sheet = Application.Worksheets(sheetName)

	' パラメータで指定された名前の ListObject （テーブル）を取得
	Set table = sheet.ListObjects(tableName)

	' テーブルのレコードが存在する場合のみ、全レコードを削除する
	If Not table.DataBodyRange Is Nothing Then
		table.DataBodyRange.Delete
	End If

CLEAN_UP:
	' 後始末
	Set table = Nothing
	Set sheet = Nothing
End Sub

 

 

最後に指定されたセルと同じ背景色のセルを数えるという、有効な使い方が思いつかないメソッドです笑い泣き

これは VBA からコールするだけではなく、ワークシートに貼りつけても使えるので、ひょっとすると面白い使い方が出来るかもしれません。

ただし、カウント対象のセルを広範囲にすると処理がかなり重いです。

 

 

指定されたセルと同じ背景色のセルを数える
Public Function CountBackColor(ByRef src As Range, ByRef rng As Range) As Long
	' カウントする背景色を取得する
	Dim srcColor As Variant
	srcColor = IIf(src.MergeCells, src.MergeArea.Item(1, 1).Interior.Color, src.Interior.Color)

	' 指定された範囲の背景色別のカウントを行う
	Dim cnt As Long
	Dim r As Range
	For Each r In rng
		' 検査先の背景色を取得する
		Dim dstColor As Variant
		dstColor = IIf(r.MergeCells, r.MergeArea.Item(1, 1).Interior.Color, r.Interior.Color)

		' 同色の場合はカウントをインクリメントする
		If srcColor = dstColor Then
			cnt = cnt + 1
		End If

		' ループ用変数の後始末
		Set r = Nothing
	Next
	CountBackColor = cnt

	End Function

 

 

使用例はこんな感じです。

B8 セルの数式の第 1 パラメータが A8、第 2 パラメータが $A$1:$D$4 となっています。

$A$1:$D$4 の範囲で、A8のセルの背景色である赤と同じ色のセルを数えます。

今回は、A1、B1、C1、D1 の 4 箇所なので、4 という結果が表示されているわけです。

 

今回はこんなところで…。