このクラスでできること
何種類もの表に対して、定期的に、同じ内容の編集を何度も繰り返し行う場合に役立つと存じます。同じ手作業を繰り返し行わなくて済むようになりますので、楽ができますの♪
行
- 指定行の除去
- 指定行の抽出
- 指定した列内で、値の重複している行を削除
- 指定した列内で、指定した値に一致した行を抽出します。
- 値の一致した行を削除
- 下側に 2 次元配列を追加
列
- 指定列の抽出(列の入れ替え)
- 指定した数分の列を最後に追加
- 列を最後に追加し、指定文字列を挿入
- 列を別の列へコピー
- 指定した関数を、列のすべての要素に適用
- 列の値を更新
- 右側に 2 次元配列を追加 (指定した 2 次元目が一致する条件で)
- キー、アイテムとなる列を指定して生成したディクショナリを返す。
- 列を 1 次元配列として返す。
- 列を 引数の 1 次元配列で更新
一方で、一度しか行わないのでしたら、本投稿のコードを使う必要性はない、という場合も多いかと存じます。
使うときのポイント
- シートへの反映は、
Range(Cells(起点行, 起点列), Cells(RangeValue.RowCount, RangeValue.ColCount))のように起点となる行番号・列番号を指定すれば自動的にサイズを調整して反映するので楽。 - 終点には RangeValue.RowCount・RangeValue.ColCount を指定するだけでよい。
- MapCol 関数、MapColWithObj 関数はとても処理が遅い。数百ならば問題なかったが、数千処理させたら 1 分以上かかった。なお、配列操作で代替すると処理時間は 1 秒未満だった。
VBA コード
''' <summary>
''' Range.Value を扱うクラスです。
''' 配列のインデックスは 1 から始まります。
''' 1 次元目を行、2 次元目を列、と用語定義します。
''' </summary>
Option Explicit
' リセット用
Private mvntInitValues As Variant
' 編集中データ
Private mvntEditeds As Variant
''' <summary>
''' Range.Value
''' </summary>
Public Property Get value() As Variant
value = mvntEditeds
End Property
''' <summary>
''' Range.Value の行数
''' </summary>
Public Property Get RowCount() As Long
RowCount = UBound(mvntEditeds, 1) - LBound(mvntEditeds, 1) + 1
End Property
''' <summary>
''' Range.Value の列数
''' </summary>
Public Property Get ColCount() As Long
ColCount = UBound(mvntEditeds, 2) - LBound(mvntEditeds, 2) + 1
End Property
''' <summary>
''' 初期化処理を実行します。
''' </summary>
''' <param name="vntRangeValue">Range.Value</param>
Public Sub Init(ByVal vntRangeValue As Variant)
' 変数をセット
mvntInitValues = vntRangeValue
mvntEditeds = vntRangeValue
End Sub
''' <summary>
''' Range.Value に 2 次元配列を追加します。
''' 1 次元目のインデックスを増やします。
''' 追加配列 2 次元目の要素数が Range.Value 2 次元目要素数よりも少ない場合、
''' 残りの要素には Empty が設定されます。
''' 追加配列 2 次元目の要素数が Range.Value 2 次元目要素数よりも多い場合、
''' 余った要素は設定されません。
''' </summary>
''' <param name="addValues">2 次元配列</param>
Public Sub Add2DArrayInRow(ByVal addValues As Variant)
' Range.Value の 1 次元目を拡張
Dim addNum As Long: addNum = UBound(addValues, 1) - LBound(addValues, 1) + 1
Dim tmps As Variant: tmps = Add1DValues(mvntEditeds, addNum)
' 拡張部分に追加配列の値を設定
' addValues をループして tmps に値を詰める。
' 要素数と要素開始インデックスのズレを意識しないで処理するために、
' ループしない配列のインデックスと、2 次元目のループ回数を把握しながら処理する。
' 1 次元目のループ回数は tmps に addValues の 1 次元目要素数を追加した
' 開始位置から終了位置までのループとなるため、気にかける必要はない。
Dim i As Long, j As Long
Dim tmp1Index As Long: tmp1Index = UBound(tmps, 1) - addNum + 1
Dim tmp2Index As Long
Dim tmp2Count As Long: tmp2Count = UBound(tmps, 2) - LBound(tmps, 2) + 1
For i = LBound(addValues, 1) To UBound(addValues, 1)
tmp2Index = LBound(tmps, 2)
For j = LBound(addValues, 2) To UBound(addValues, 2)
' tmps の 2 次元目インデックス外へのアクセスを防止
If (j - LBound(addValues, 2) + 1) > tmp2Count Then: Exit For
tmps(tmp1Index, tmp2Index) = addValues(i, j)
Next j
tmp1Index = tmp1Index + 1
Next i
mvntEditeds = tmps
End Sub
''' <summary>
''' 2 次元配列の 1 次元目の最後に指定数分の要素を追加します。
''' </summary>
''' <param name="values">2 次元配列</param>
''' <param name="addNum">追加するインデックス数</param>
''' <returns>2 次元配列</returns>
Private Function Add1DValues(ByVal values As Variant, ByVal addNum As Long) As Variant
Dim tmps As Variant: tmps = WorksheetFunction.Transpose(values)
Add1DValues = WorksheetFunction.Transpose(Add2DValues(tmps, addNum))
End Function
''' <summary>
''' Range.Value に 2 次元配列を追加します。
''' 引数 2 次元配列の指定インデックス列要素と
''' Range.Value の指定インデックス列要素を検証して一致した場合、
''' 行の最後に引数配列の対応行の内容を設定します。
''' 一致しなかった行には Empty を設定します。
''' </summary>
''' <param name="rangeIndex">Range.Value の評価対象列インデックス</param>
''' <param name="addValues">2 次元配列</param>
''' <param name="valuesIndex">引数 2 次元配列のキー列インデックス</param>
Public Sub AddMatched2DArray( _
ByVal rangeIndex As Long, _
ByVal addValues As Variant, _
ByVal valuesIndex As Long)
' 列を追加した Range.Value を生成
Dim addNum As Long: addNum = UBound(addValues, 2) - LBound(addValues, 2) + 1
Dim tmps As Variant: tmps = Add2DValues(mvntEditeds, addNum)
' 2 次元配列の 2 次元目要素をキー、1 次元目インデックスをアイテムとした
' ディクショナリを生成(万が一重複がある場合はインデックスの小さなものを残す。
' そのために降順で For ループを回す)
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = UBound(addValues, 1) To LBound(addValues, 1) Step - 1
dic(addValues(i, valuesIndex)) = i
Next i
' 配列要素の値を評価し、一致した場合に拡張した配列部分に値を詰める。
Dim j As Long, k As Long
Dim addedStartIndex As Long
For j = LBound(tmps, 1) To UBound(tmps, 1)
' 1 行ずつ進めていき、一致するかを評価
If dic.Exists(tmps(j, rangeIndex)) Then
' 追加した列に値を設定
addedStartIndex = UBound(tmps, 2) - addNum + 1
For k = LBound(addValues, 2) To UBound(addValues, 2)
tmps(j, addedStartIndex) = addValues(dic.Item(tmps(j, rangeIndex)), k)
addedStartIndex = addedStartIndex + 1
Next k
End If
Next j
mvntEditeds = tmps
End Sub
''' <summary>
''' 指定した行のみを抽出します。
''' 行は指定した順番に並び替えられます。
''' </summary>
''' <param name="indexes">抽出したい行のインデックスを格納した配列</param>
Public Sub ExtractRows(ByVal indexes As Variant)
mvntEditeds = Extract1DValues(mvntEditeds, indexes)
End Sub
''' <summary>
''' 2 次元配列から指定した 1 次元目の要素を抽出します。
''' 行は指定した順番に並び替えられます。
''' 抽出対象の 1 次元目が無い場合、2 次元目には Empty が入ります。
''' </summary>
''' <param name="values">2 次元配列</param>
''' <param name="indexes">抽出したい 1 次元目要素のインデックスを格納した配列</param>
''' <returns>2 次元配列</returns>
Private Function Extract1DValues(ByVal values As Variant, ByVal indexes As Variant) As Variant
Dim indexCount As Long: indexCount = UBound(indexes) - LBound(indexes) + 1
Dim results As Variant: ReDim results( _
LBound(values, 1) To LBound(values, 1) + indexCount - 1, _
LBound(values, 2) To UBound(values, 2) _
)
' インデックスに対応する配列の行を取得
Dim index As Variant
Dim i As Long: i = 1
Dim j As Long
' indexes のインデックス範囲の影響を受けないようにするため、
' results の 1 次元目ではなく indexes を For Each する。
For Each index In indexes
For j = LBound(results, 2) To UBound(results, 2)
' 1 次元目のインデックス範囲外の場合は、2 次元目は空にする。
If index < LBound(values, 1) Or UBound(values, 1) < index Then
Exit For
End If
results(i, j) = values(index, j)
Next j
i = i + 1
Next index
Extract1DValues = results
End Function
''' <summary>
''' 指定した行を除去します。
''' </summary>
''' <param name="indexes">除去したい行のインデックスを格納した配列</param>
Public Sub RemoveRows(ByVal indexes As Variant)
' 除去対象「以外」のインデックスを取得
Dim others As Object: Set others = CreateObject("Scripting.Dictionary")
Dim i As Long, index As Variant
For i = LBound(mvntEditeds, 1) To UBound(mvntEditeds, 1)
For Each index In indexes
If Not i = index Then: Call others.Add(i, Null)
Next index
Next i
' 除去対象「以外」のインデックスの配列を生成
Dim extractIndexes As Variant: extractIndexes = others.Keys
' 除去対象「以外」のインデックスで 2 次元配列の行を抽出
mvntEditeds = Extract1DValues(mvntEditeds, extractIndexes)
End Sub
''' <summary>
''' 指定した列内で、値に一致した行を抽出します。
''' </summary>
''' <param name="index">列のインデックス</param>
''' <param name="value">値</param>
Public Sub ExtractMatchedRows(ByVal index As Long, ByVal value As Variant)
Dim tmps As Variant: tmps = mvntEditeds
' 値に一致する残す行のインデックスを選別
Dim i As Long
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
For i = LBound(tmps, 1) To UBound(tmps, 1)
If tmps(i, index) = value Then: Call dic.Add(i, Null)
Next i
' 残す行インデックスの配列を生成
Dim extractIndexes As Variant: extractIndexes = dic.Keys
' 残す行のみを抽出
mvntEditeds = Extract1DValues(mvntEditeds, extractIndexes)
End Sub
''' <summary>
''' 指定した列内で、値に一致した行を削除します。
''' </summary>
''' <param name="index">列のインデックス</param>
''' <param name="value">値</param>
Public Sub RemoveMatchedRows(ByVal index As Long, ByVal value As Variant)
Dim tmps As Variant: tmps = mvntEditeds
' 値に一致しない残す行のインデックスを選別
Dim i As Long
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
For i = LBound(tmps, 1) To UBound(tmps, 1)
If Not tmps(i, index) = value Then: Call dic.Add(i, Null)
Next i
' 残す行インデックスの配列を生成
Dim extractIndexes As Variant: extractIndexes = dic.Keys
' 残す行のみを抽出
mvntEditeds = Extract1DValues(mvntEditeds, extractIndexes)
End Sub
''' <summary>
''' 指定した列内で、値の重複している行を削除します。
''' </summary>
''' <param name="index">列のインデックス</param>
Public Sub RemoveDuplicateRows(ByVal index As Long)
' 指定列の値の 1 次元配列を取得
Dim cols As Variant: cols = Get2DValues(mvntEditeds, index)
' 重複を評価し、残す行のインデックスを抽出したディクショナリを生成
Dim i As Long
Dim noDuplicates As Object: Set noDuplicates = CreateObject("Scripting.Dictionary")
For i = LBound(cols) To UBound(cols)
' 重複の中で最初を残す。
If Not noDuplicates.Exists(cols(i)) Then: Call noDuplicates.Add(cols(i), i)
Next i
' 残す行インデックスの配列を生成
Dim extractIndexes As Variant: extractIndexes = noDuplicates.Items
' 残す行のみを抽出
mvntEditeds = Extract1DValues(mvntEditeds, extractIndexes)
End Sub
''' <summary>
''' 指定列を 1 次元配列にして返します。
''' </summary>
''' <param name="index">列のインデックス</param>
''' <returns>1 次元配列</returns>
Public Function GetColArray(ByVal index As Long) As Variant
GetColArray = Get2DValues(mvntEditeds, index)
End Function
''' <summary>
''' 2 次元配列から、指定した 2 次元目を 1 次元配列にして返します。
''' </summary>
''' <param name="values">2 次元配列</param>
''' <param name="index">抽出したい 2 次元目要素のインデックス</param>
''' <returns>1 次元配列</returns>
Private Function Get2DValues(ByVal values As Variant, ByVal index As Long) As Variant
Dim i As Long
Dim results As Variant: ReDim results(LBound(values, 1) To UBound(values, 1))
For i = LBound(values, 1) To UBound(values, 1)
results(i) = values(i, index)
Next i
Get2DValues = results
End Function
''' <summary>
''' 指定した列のみを抽出します。
''' 列は指定した順番に並び替えられます。
''' </summary>
''' <param name="indexes">抽出したい列のインデックスを格納した配列</param>
Public Sub ExtractCols(ByVal indexes As Variant)
' Transpose 関数で行列を入れ替えて、
' インデックスを指定した行(もともとの列)を取得することで抽出を可能にする。
Dim before2nd1st As Variant: before2nd1st = WorksheetFunction.Transpose(mvntEditeds)
Dim after2nd1st As Variant: after2nd1st = Extract1DValues(before2nd1st, indexes)
Dim after1st2nd As Variant: after1st2nd = WorksheetFunction.Transpose(after2nd1st)
mvntEditeds = after1st2nd
End Sub
''' <summary>
''' Range.Value の最後に指定数分の列を追加します。
''' </summary>
''' <param name="colNumber">追加した列数</param>
Public Sub AddCols(ByVal colNumber As Long)
mvntEditeds = Add2DValues(mvntEditeds, colNumber)
End Sub
''' <summary>
''' 2 次元配列の 2 次元目の最後に指定数分のインデックスを追加します。
''' </summary>
''' <param name="values">2 次元配列</param>
''' <param name="addNum">追加するインデックス数</param>
''' <returns>2 次元配列</returns>
Private Function Add2DValues(ByVal values As Variant, ByVal addNum As Long) As Variant
Dim results As Variant: ReDim results( _
LBound(values, 1) To UBound(values, 1), _
LBound(values, 2) To UBound(values, 2) + addNum _
)
' インデックス外へアクセスしないよう、サイズがより小さい法でループ
Dim i As Long, j As Long
For i = LBound(values, 1) To UBound(values, 1)
For j = LBound(values, 2) To UBound(values, 2)
results(i, j) = values(i, j)
Next j
Next i
Add2DValues = results
End Function
''' <summary>
''' インデックス列の値を更新します。
''' </summary>
''' <param name="index">インデックス</param>
''' <param name="value">適用する値</param>
Public Sub ApplyValueToCol(ByVal index As Long, ByVal value As Variant)
mvntEditeds = ApplyValueTo2D(mvntEditeds, index, value)
End Sub
''' <summary>
''' インデックス列を配列の値で更新します。
''' 引数配列要素が不足する場合、不足部分の値は更新されません。
''' 引数配列要素が余分な場合、余分部分は無視されます。
''' </summary>
''' <param name="index">インデックス</param>
''' <param name="values">適用する 1 次元配列</param>
Public Sub ApplyArrayToCol(ByVal index As Long, ByVal values As Variant)
Dim tmps As Variant: tmps = mvntEditeds
Dim valuesIndex As Long: valuesIndex = LBound(values)
Dim i As Long
For i = LBound(tmps, 1) To UBound(tmps, 1)
If valuesIndex > UBound(values) Then: Exit For
tmps(i, index) = values(valuesIndex)
valuesIndex = valuesIndex + 1
Next i
mvntEditeds = tmps
End Sub
''' <summary>
''' 2 次元配列の 2 次元目インデックスに対応する要素を更新します。
''' </summary>
''' <param name="values">2 次元配列</param>
''' <param name="index">インデックス</param>
''' <param name="value">適用する値</param>
''' <returns>2 次元配列</returns>
Private Function ApplyValueTo2D( _
ByVal values As Variant, _
ByVal index As Long, _
ByVal value As Variant) As Variant
Dim results As Variant: results = values
Dim i As Long
For i = LBound(results, 1) To UBound(results, 1)
results(i, index) = value
Next i
ApplyValueTo2D = results
End Function
''' <summary>
''' Range.Value の最後に 1 列追加し、追加した各要素に指定した変数を反映します。
''' </summary>
''' <param name="value">追加される列の要素に挿入する値</param>
Public Sub AddColWithValue(ByVal value As Variant)
Dim results As Variant: results = mvntEditeds
results = Add2DValues(results, 1)
mvntEditeds = ApplyValueTo2D(results, UBound(results, 2), value)
End Sub
''' <summary>
''' 列を別の列へコピーします。
''' </summary>
''' <param name="fromIndex">コピー元の列インデックス</param>
''' <param name="toIndex">コピー先の列インデックス</param>
Public Sub CopyCol(ByVal fromIndex As Long, ByVal toIndex As Long)
Dim results As Variant: results = mvntEditeds
' 捜査対象の列番号は判明しているため、行のみループすればよい
Dim i As Long
For i = LBound(results, 1) To UBound(results, 1)
results(i, toIndex) = results(i, fromIndex)
Next i
mvntEditeds = results
End Sub
''' <summary>
''' インスタンスの関数を列のすべての要素に適用します。
''' 適用する関数には、Range.Value の 1 次元目インデックス、
''' 2 次元目インデックス、Range.Value (の 2 次元配列) を引数として渡します。
''' </summary>
''' <param name="obj">関数の属するインスタンス</param>
''' <param name="method">関数名文字列</param>
''' <param name="index">コピー先の列インデックス</param>
Public Sub MapCol( _
ByVal obj As Object, _
ByVal method As String, _
ByVal index As Long)
mvntEditeds = Map2DValues(obj, method, mvntEditeds, index)
End Sub
''' <summary>
''' インスタンスの関数を 2 次元配列の指定した 2 次元目の
''' すべての要素に適用し、返された値を適用した 2 次元配列を返します。
''' 適用する関数には、2 次元配列の 1 次元目インデックス、
''' 2 次元目インデックス、2 次元配列を引数として渡します。
''' </summary>
''' <param name="obj">関数の属するインスタンス</param>
''' <param name="method">関数名文字列</param>
''' <param name="index">コピー先の列インデックス</param>
Private Function Map2DValues( _
ByVal obj As Object, _
ByVal method As String, _
ByVal values As Variant, _
ByVal index As Long) As Variant
Dim results As Variant: results = values
Dim i As Long
For i = LBound(results, 1) To UBound(results, 1)
results(i, index) = CallByName(obj, method, VbMethod, i, index, values)
Next i
Map2DValues = results
End Function
''' <summary>
''' インスタンスの関数を列のすべての要素に適用します。
''' 適用する関数には、Range.Value の 1 次元目インデックス、
''' 2 次元目インデックス、Range.Value (の 2 次元配列)、
''' ディクショナリなどのオブジェクトを引数として渡します。
''' </summary>
''' <param name="obj">関数の属するインスタンス</param>
''' <param name="method">関数名文字列</param>
''' <param name="index">コピー先の列インデックス</param>
''' <param name="valueObj">関数に渡すオブジェクト</param>
Public Sub MapColWithObj( _
ByVal obj As Object, _
ByVal method As String, _
ByVal index As Long, _
ByVal valueObj As Object)
Dim results As Variant: results = mvntEditeds
Dim i As Long
For i = LBound(results, 1) To UBound(results, 1)
results(i, index) = CallByName(obj, method, VbMethod, i, index, mvntEditeds, valueObj)
Next i
mvntEditeds = results
End Sub
''' <summary>
''' 指定した列で構成されたキー、アイテムのディクショナリを返します。
''' キーが重複した場合、最初を残します。
''' </summary>
''' <param name="keyIndex">キーに設定する 2 次元目インデックス</param>
''' <param name="valueIndex">アイテムに設定する 2 次元目インデックス</param>
''' <returns>Range.Value 2 次元配列</returns>
Public Function GetColDictionary(ByVal keyIndex As Long, ByVal valueIndex As Long) As Object
Dim tmps As Variant: tmps = mvntEditeds
Dim keyArray As Variant: keyArray = Get2DValues(tmps, keyIndex)
Dim valueArray As Variant: valueArray = Get2DValues(tmps, valueIndex)
Dim i As Long
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
For i = LBound(tmps, 1) To UBound(tmps, 1) Step -1
dic(keyArray(i)) = valueArray(i)
Next i
Set GetColDictionary = dic
End Function
''' <summary>
''' 編集をリセットします。
''' </summary>
Public Sub Reset()
mvntEditeds = mvntInitValues
End Sub
''' <summary>
''' Range.Value を文字列にして返します。
''' 要素の区切り文字は , です。1 行ごとに改行が入ります。
''' </summary>
''' <returns>要素をつなげた文字列</returns>
Public Function ToString()
Dim i As Long, j As Long
Dim s As String
For i = LBound(mvntEditeds, 1) To UBound(mvntEditeds, 1)
For j = LBound(mvntEditeds, 2) To UBound(mvntEditeds, 2)
s = s & mvntEditeds(i, j) & ", "
Next j
s = s & vbNewLine
Next i
ToString = s
End Function
''' <summary>
''' Range.Value の指定した行を文字列にして返します。
''' 要素の区切り文字は , です。
''' </summary>
''' <param name="index">インデックス</param>
''' <returns>要素をつなげた文字列</returns>
Public Function ToStringRow(ByVal index As Long)
Dim i As Long
Dim s As String
For i = LBound(mvntEditeds, 2) To UBound(mvntEditeds, 2)
s = s & mvntEditeds(index, i) & ", "
Next i
ToString = s
End Function
''' <summary>
''' Range.Value の指定した列を文字列にして返します。
''' 要素の区切り文字は , です。
''' </summary>
''' <param name="index">インデックス</param>
''' <returns>要素をつなげた文字列</returns>
Public Function ToStringCol(ByVal index As Long)
Dim i As Long
Dim s As String
For i = LBound(mvntEditeds, 1) To UBound(mvntEditeds, 1)
s = s & mvntEditeds(i, index) & ", "
Next i
ToString = s
End Function
続いて、確認用のコードです。
Option Explicit
Public Sub TestRangeValue()
Dim book As Workbook: Set book = Workbooks("RangeValue.xlsm")
' 準備
With book.Worksheets("Sheet1")
Dim maxRow As Long: maxRow = .Cells(Rows.Count, 1).End(xlUp).Row
Dim maxCol As Long: maxCol = .Cells(1, Columns.Count).End(xlToLeft).Column
Dim values As Variant: values = .Range(.Cells(1, 1), .Cells(maxRow, maxCol)).Value
End With
' RangeValue を生成、2 次元配列を編集
Dim rv As RangeValue: Set rv = New RangeValue
Call rv.Init(values)
Call rv.ExtractCols(Array(1, 2, -1, 8, 6))
Call rv.RemoveDuplicateRows(2)
Call rv.AddColWithValue("★")
Call rv.AddCols(1)
Call rv.CopyCol(1, 7)
Call rv.ExtractRows(Array(1, 2, 3, 4, 5, 6))
Call rv.MapCol(ThisWorkbook, "Sequence", 1)
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
Call dic.Add("男", "おとこ")
Call dic.Add("女", "おんな")
Call rv.MapColWithObj(ThisWorkbook, "SexKagiToKana", 3, dic)
Call rv.ApplyValueToCol(6, "○")
' 確認出力
Debug.Print rv.ToString
' シートに反映
With book.Worksheets("Sheet2")
.Range(.Cells(1, 1), .Cells(rv.RowCount, rv.ColCount)) = rv.value
End With
End Sub
''' <summary>
''' 2 次元配列の 1 次元目インデックスが 1 の場合は要素をそのまま返し、
''' それ以外の場合は 1 次元目インデックス - 1 を返します。
''' </summary>
''' <param name="first">1 次元目インデックス</param>
''' <param name="second">2 次元目インデックス</param>
''' <param name="values">2 次元配列</param>
''' <returns>編集された要素</returns>
Public Function Sequence( _
ByVal first As Long, _
ByVal second As Long, _
ByVal values As Variant) As Variant
If first = 1 Then
Sequence = values(first, second)
Exit Function
End if
Sequence = first - 1
End Function
''' <summary>
''' 2 次元配列の 2 次元目インデックス 5 の要素を評価し、
''' ディクショナリに対応する値を返します。
''' 対応する値が無い場合は要素をそのまま返します。
''' </summary>
''' <param name="first">1 次元目インデックス</param>
''' <param name="second">2 次元目インデックス</param>
''' <param name="values">2 次元配列</param>
''' <param name="dic">ディクショナリ</param>
''' <returns>編集された要素</returns>
Public Function SexKagiToKana( _
ByVal first As Long, _
ByVal second As Long, _
ByVal values As Variant, _
ByVal dic As Object) As Variant
Dim sex As String: sex = values(first, 5)
If dic.Exists(sex) Then
SexKagiToKana = dic.Item(sex)
Else
SexKagiToKana = sex
End If
End Function
Public Sub TestAddMatched2DArray()
Dim book As Workbook: Set book = Workbooks("RangeValue.xlsm")
' 準備
With book.Worksheets("Sheet3")
Dim values As Variant: values = .Range(.Cells(1, 1), .Cells(11, 4)).Value
Dim value2s As Variant: value2s = .Range(.Cells(1, 6), .Cells(10, 8)).Value
End With
' RangeValue を生成、2 次元配列を編集
Dim rv As RangeValue: Set rv = New RangeValue
Call rv.Init(values)
Call rv.AddMatched2DArray(2, value2s, 2)
' 確認出力
Debug.Print rv.ToString
' シートに反映
With book.Worksheets("Sheet3")
.Range(.Cells(15, 1), .Cells(15 + rv.RowCount -1, 1 + rv.ColCount -1)) = rv.value
End With
End Sub
Public Sub TestGetColDictionary()
' 準備
With Workbooks("RangeValue.xlsm").Worksheets("Sheet1")
Dim maxRow As Long: maxRow = .Cells(Rows.Count, 1).End(xlUp).Row
Dim maxCol As Long: maxCol = .Cells(1, Columns.Count).End(xlToLeft).Column
Dim values As Variant: values = .Range(.Cells(1, 1), .Cells(maxRow, maxCol)).Value
End With
' RangeValue を生成、2 次元配列を編集
Dim rv As RangeValue: Set rv = New RangeValue
Call rv.Init(values)
Dim dic As Object: Set dic = rv.GetColDictionary(2, 8)
' 確認
Dim key As Variant
For Each key In dic.keys
Debug.Print "Key: " & key & ", Item: " & dic.Item(key)
Next key
End Sub
Public Sub TestAdd2DArrayInRow()
' 準備
With Workbooks("RangeValue.xlsm").Worksheets("Sheet1")
Dim values As Variant: values = .Range(.Cells(2, 2), .Cells(4, 3)).Value
Dim sames As Variant: sames = .Range(.Cells(2, 4), .Cells(4, 5)).Value
Dim shorts As Variant: shorts = .Range(.Cells(2, 4), .Cells(4, 4)).Value
Dim longs As Variant: longs = .Range(.Cells(2, 4), .Cells(4, 6)).Value
End With
' RangeValue を生成、2 次元配列を編集
Dim rv As RangeValue: Set rv = New RangeValue
Call rv.Init(values)
Call rv.Add2DArrayInRow(sames)
Call rv.Add2DArrayInRow(shorts)
Call rv.Add2DArrayInRow(longs)
' 確認
Debug.Print rv.ToString
End Sub
Public Sub TestGetAndApply()
' 準備
With Workbooks("RangeValue.xlsm").Worksheets("Sheet1")
Dim maxCol As Long: maxCol = .Cells(1, Columns.Count).End(xlToLeft).Column
Dim values As Variant: values = .Range(.Cells(1, 1), .Cells(4, maxCol)).Value
End With
' RangeValue を生成、2 次元配列を編集
Dim rv As RangeValue: Set rv = New RangeValue
Call rv.Init(values)
Call rv.ExtractCols(Array(1, 6))
' 配列取り出し確認。そして適用先と配列サイズが一致する場合の確認
Dim cols As Variant: cols = rv.GetColArray(2)
Dim i As Long
For i = LBound(cols) To UBound(cols)
cols(i) = cols(i) & "○"
Next i
Call rv.ApplyArrayToCol(2, cols)
Debug.Print rv.ToString
' 適用先よりも配列サイズが短い場合の確認
Dim shorts As Variant: shorts = Array("性別", "s", "s")
Call rv.ApplyArrayToCol(2, shorts)
Debug.Print rv.ToString
' 適用先よりも配列サイズが長い場合の確認
Dim longs As Variant: longs = Array("性別", "l", "l", "l", "l", "l", "l")
Call rv.ApplyArrayToCol(2, longs)
Debug.Print rv.ToString
End Sub
Public Sub TestExtractMatchedRows()
' 準備
With Workbooks("RangeValue.xlsm").Worksheets("Sheet1")
Dim maxRow As Long: maxRow = .Cells(Rows.Count, 1).End(xlUp).Row
Dim maxCol As Long: maxCol = .Cells(1, Columns.Count).End(xlToLeft).Column
Dim values As Variant: values = .Range(.Cells(1, 1), .Cells(maxRow, maxCol)).Value
End With
' RangeValue を生成、2 次元配列を編集
Dim rv As RangeValue: Set rv = New RangeValue
Call rv.Init(values)
Call rv.ExtractMatchedRows(2, "島田")
' 確認
Debug.Print rv.ToString
End Sub
確認用のエクセルの準備
- RangeValue.xlsm
- Sheet1
- Sheet2
- Sheet3
Sheet1 は A1 セルから次の内容を入力しました。
| 連番 | 姓 | 名 | 姓（カタカナ） | 名（カタカナ） | 性別 | 電話番号 | 生年月日 |
| 1 | 島田 | 良雄 | シマダ | ヨシオ | 男 | 0182-79-7055 | 1962/7/31 |
| 2 | 横尾 | 亜紀 | ヨコオ | アキ | 女 | 0776-3-1466 | 1973/7/31 |
| 3 | 山田 | 愛結 | ヤマダ | アユ | 女 | 0853-2-5257 | 1973/1/29 |
| 4 | 島田 | 利幸 | シマダ | トシユキ | 男 | 076-566-3223 | 1986/3/1 |
| 5 | 滝田 | 敬三 | タキタ | ケイゾウ | 男 | 0747-07-8273 | 1961/7/8 |
| 6 | 佐々木 | 彩奈 | ササキ | アヤナ | 女 | 096-299-7597 | 1969/2/20 |
| 7 | 毛利 | 寿晴 | モウリ | トシハル | 男 | 0858-99-0921 | 1962/1/27 |
| 8 | 水谷 | 幸夫 | ミズタニ | ユキオ | 男 | 0495-80-7481 | 1989/11/26 |
| 9 | 高田 | 一路 | コウダ | カズミチ | 男 | 0124-06-9241 | 1989/11/26 |
| 10 | 島田 | 優希 | シマダ | ユウキ | 女 | 028-181-2775 | 1980/11/26 |
Sheet2 には何も入れません。
Sheet3 です。これは AddMatched2DArray 関数のテスト用です。
| 連番 | キー | 姓 | 名 | 連番 | キー | 値 | |
| 1 | c | 島田 | 良雄 | 1 | a | 北海道 | |
| 2 | c | 横尾 | 亜紀 | 2 | b | 青森県 | |
| 3 | a | 山田 | 愛結 | 3 | c | 岩手県 | |
| 4 | b | 島田 | 利幸 | 4 | d | 秋田県 | |
| 5 | d | 島田 | 敬三 | 5 | e | 山形県 | |
| 6 | e | 佐々木 | 彩奈 | 6 | f | 宮城県 | |
| 7 | f | 毛利 | 寿晴 | 7 | g | 福島県 | |
| 8 | g | 水谷 | 幸夫 | 8 | h | 茨城県 | |
| 9 | h | 高田 | 一路 | 9 | i | 栃木県 | |
| 10 | z | 島田 | 優希 |
結果
TestRangeValue の確認
連番, 姓, 性別, 生年月日, 性別, ○, 連番, 1, 島田, おとこ, 1962/7/31, 男, ○, 1, 2, 横尾, おんな, 1973/1/29, 女, ○, 2, 3, 山田, おんな, 1988/9/10, 女, ○, 3, 4, 滝田, おとこ, 1961/7/8, 男, ○, 5, 5, 佐々木, おんな, 1969/2/20, 女, ○, 6,
エクセル Sheet2 の A1 セルからは次のように反映されました。
| 連番 | 姓 | 性別 | 生年月日 | 性別 | ○ | 連番 |
| 1 | 島田 | おとこ | 1962/7/31 | 男 | ○ | 1 |
| 2 | 横尾 | おんな | 1973/1/29 | 女 | ○ | 2 |
| 3 | 山田 | おんな | 1988/9/10 | 女 | ○ | 3 |
| 4 | 滝田 | おとこ | 1961/7/8 | 男 | ○ | 5 |
| 5 | 佐々木 | おんな | 1969/2/20 | 女 | ○ | 6 |
TestAddMatched2DArray の確認
連番, キー, 姓, 名, 連番, キー, 値, 1, c, 島田, 良雄, 3, c, 岩手県, 2, c, 横尾, 亜紀, 3, c, 岩手県, 3, a, 山田, 愛結, 1, a, 北海道, 4, b, 島田, 利幸, 2, b, 青森県, 5, d, 滝田, 敬三, 4, d, 秋田県, 6, e, 佐々木, 彩奈, 5, e, 山形県, 7, f, 毛利, 寿晴, 6, f, 宮城県, 8, g, 水谷, 幸夫, 7, g, 福島県, 9, h, 高田, 一路, 8, h, 茨城県, 10, z, 島田, 優希, , , ,
エクセル Sheet3 です。次のデータが書き込まれました♪
| 連番 | キー | 姓 | 名 | 連番 | キー | 値 |
| 1 | c | 島田 | 良雄 | 3 | c | 岩手県 |
| 2 | c | 横尾 | 亜紀 | 3 | c | 岩手県 |
| 3 | a | 山田 | 愛結 | 1 | a | 北海道 |
| 4 | b | 島田 | 利幸 | 2 | b | 青森県 |
| 5 | d | 島田 | 敬三 | 4 | d | 秋田県 |
| 6 | e | 佐々木 | 彩奈 | 5 | e | 山形県 |
| 7 | f | 毛利 | 寿晴 | 6 | f | 宮城県 |
| 8 | g | 水谷 | 幸夫 | 7 | g | 福島県 |
| 9 | h | 高田 | 一路 | 8 | h | 茨城県 |
| 10 | z | 島田 | 優希 |
TestGetColDictionary の確認
Key: 島田, Item: 1962/07/31 Key: 高田, Item: 1989/11/26 Key: 水谷, Item: 1972/10/24 Key: 毛利, Item: 1962/01/27 Key: 佐々木, Item: 1969/02/20 Key: 滝田, Item: 1961/07/08 Key: 山田, Item: 1988/09/10 Key: 横尾, Item: 1973/01/29 Key: 姓, Item: 年月日
TestAdd2DArrayInRow の確認
島田, 良雄, 横尾, 亜紀, 山田, 愛結, シマダ, ヨシオ ヨコオ, アキ, ヤマダ, アユ, シマダ, ヨコオ, , ヤマダ, , シマダ, ヨシオ ヨコオ, アキ, ヤマダ, アユ,
TestGetAndApply の確認
連番, 性別○, 1, 男○, 2, 女○, 3, 女○, 連番, 性別, 1, s, 2, s, 3, 女○, 連番, 性別, 1, l, 2, l, 3, l,
おまけ。できない (と思う) こと
行・列の要素を動的に更新
X 列と Y 列を足しあわせて 10 倍した値で Z 列を更新、、、といった操作ですわね。関数型プログラミングでいう map に当たるかと存じます。
指定した関数を、列のすべての要素に適用する、MapCol 関数と MapColWithObj 関数を書きましたの♪これで実現可能になりました！ただ、ものすごく遅く、数千回処理では使えないと感じておりますの＞＜。
おわりに
参考になったページです。ありがとう存じます！
以上です。