[VBA] リストから複数の2次元配列を作成する

質問

こちらの識者の方々にはいつもお世話になっています。
VBAの質問です。

環境は下記になります。
OS=windows7 pro 64bit
Office=Excel2010(14.0.7128.5000)

・やりたいこと
図のようなリストがあり、A/B/Cそれぞれのグループの2次元配列を作成したい。
aryA(1,1) = "アケビ"
aryA(1,2) = "A"
aryA(2,1) = "アボカド"
aryA(2,2) = "A"

aryB(1,1) = "アセロラ"
aryB(1,2) = "B"
aryB(2,1) = "イチジク"
aryB(2,2) = "B"

aryC(1,1) = "アンズ"
aryC(1,2) = "C"
aryC(2,1) = "イチゴ"
aryC(2,2) = "C"
のような感じです。

このような場合の例文を教えていただけますでしょうか。

質問に不備不足等ございましたらご指摘ください。
ご面倒お掛けしますがよろしくお願いします。

回答No.4

real beatin（@realbeatin）

' '　ーーー
' '　参照設定 [Scripting] ■　Microsoft Scripting Runtime　< 共通
' '　参照設定 [ADODB] ■　Microsoft ActiveX Data Objects 6.1 Library 　 < Sub Re_j3()
　' '　ーーー
Option Explicit
' ' 「二次元配列」を（複数、それぞれに名前を付けて）連想配列として「Dictionaryオブジェクト」に格納する
Private oDict As New Scripting.Dictionary　' op１★　[Scripting]参照設定した場合
'Private oDict As Object　'　op２★ [Scripting]参照設定しない場合
　' '　ーーー

' ' .Sort + .ColumnDifferences -> Dictionary
' ' // 一旦、対象範囲を[グループ]でソートしてから実行し後で元に戻す
Sub Re_c2()　'　W9155487
Dim rngTable As Range
Dim r As Range, r0 As Range
Sheets("Sheet1").Select　'　シート名？　選択不要？
'　Set oDict = CreateObject("Scripting.Dictionary")　'　op２★ [Scripting]参照設定しない場合のみ イキ
　Set rngTable = Range("A1:C" & Cells(Rows.Count, "B").End(xlUp).Row)
　rngTable.Sort Key1:=rngTable(2), Order1:=xlAscending, Header:=xlYes
　Set r = Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row)
　On Error Resume Next
　Do
　　Set r0 = r(1)
　　Set r = r.ColumnDifferences(r0)
　　If Err Then
　　　oDict("ary" & r(1).Value) = r.Offset(, -1).Resize(, 2).Value
　　　Exit Do
　　Else
　　　oDict("ary" & r(0).Value) = Range(r0, r(0)).Offset(, -1).Resize(, 2).Value
　　End If
　Loop
　On Error GoTo 0
　rngTable.Sort Key1:=rngTable(3), Order1:=xlAscending, Header:=xlYes
' '　ーー Dictionary 格納処理　↑以上↑　ーー
End Sub
　' '　ーーー

' ' ADODB.Recordset -> Dictionary
' ' // 一度も保存していない新規ブックでは、使用不可。
Sub Re_j3()　'　W9155487
Const myProv = "Microsoft.ACE.OLEDB.12.0"　'　固定
Const adOpenStatic = 3, adLockOptimistic = 3, adCmdText = 1　'　固定
Dim oConn As New ADODB.Connection　' op１★　[ADODB]参照設定した場合
'Dim oConn　As Object　' op２★　[ADODB]参照設定しない場合
Dim oRs As New ADODB.Recordset　' op１★　[ADODB]参照設定した場合
'Dim oRs　As Object　' op２★　[ADODB]参照設定しない場合　'
Dim aryKeys()　'　グループ名配列
Dim buf, vKey
Dim myFullPath As String　'　ブックのフルパス
Dim mySheet As String　'　シート名
Dim myRef As String　'　セル範囲を参照する文字列
Dim myField As String　'　セル範囲を参照する文字列
' ' ◆ 指定/確認は正確に！！間違っていればエラーになります
' ' ブックのフルパス
　myFullPath = ActiveWorkbook.FullName
' ' シート名　◆要指定
　mySheet = "Sheet1"
' ' セル範囲を列範囲として参照する文字列　◆要確認
　myRef = "A:B"
' ' 抽出対象フィールド名 ・・・ "[グループ]"　◆要確認
　myField = "[" & Sheets(mySheet).Range("B1").Value & "]"
' ' ●--- Connection ---●
'　Set oConn = CreateObject("ADODB.Connection")　' op２★　[ADODB]参照設定しない場合
' ' データソース（Excelブック）へのコネクション 開く
　oConn.Open "Provider=" & myProv & _
　　　　";Data Source=" & myFullPath & _
　　　　";Extended Properties=""Excel 12.0;HDR=Yes;ReadOnly=True;"""
' ' ●--- Recordset ---●
'　Set oRs = CreateObject("ADODB.RecordSet")　' op２★　[ADODB]参照設定しない場合
' ' レコードセット 開く グループ名（重複のないキー配列） 取得
　oRs.Open "SELECT DISTINCT " & myField & " FROM [" & mySheet & "$" & myRef & "]", _
　　oConn, adOpenStatic, adLockOptimistic, adCmdText
' ' グループ名（重複のないキー配列） 配列変数に格納（YSize:0 To 0,XSize:0 To count-1）
　aryKeys() = oRs.GetRows
　oRs.Close　'　Recordset 一旦閉じる
' ' レコードセット 再度開く 全部 取得
　oRs.Open "SELECT * FROM [" & mySheet & "$" & myRef & "]", _
　　oConn, adOpenStatic, adLockOptimistic, adCmdText
' ' ●--- Dictionary ---●
'　Set oDict = CreateObject("Scripting.Dictionary")　'　op２★ [Scripting]参照設定しない場合のみ イキ
' ' ●--- Recordset To Dictionary ---●
' ' ▽　グループ名配列を総当たりループ　▽
　For Each vKey In aryKeys()
　　' ' ○　Recordset フィルター
　　oRs.Filter = myField & " = '" & vKey & "'"
　　' ' ○　Recordset 抽出済配列（行列反転）（YSize:0 To フィールド数-1,XSize:0 To 抽出件数-1）取得
　　buf = oRs.GetRows
　　' ' ○　行列反転した配列（YSize:1 To 抽出件数,XSize:1 To フィールド数）をDictionaryに名前を付けて格納
　　oDict("ary" & vKey) = Application.Transpose(buf)
　Next
' ' ●--- object 後片付け ---●- Recordset -
　oRs.Close:　Set oRs = Nothing
' ' ●--- object 後片付け ---●- Connection -
　oConn.Close:　Set oConn = Nothing
' '　ーー 格納処理　↑以上↑　ーー

' ' 処理例として　新規シート上で結果確認
Dim v, mtxTemp
　Worksheets.Add
　For Each v In oDict.Keys
　　With Cells(2, Columns.Count).End(xlToLeft)
　　　mtxTemp = oDict(v)
　　　.Cells(0, 2) = "【" & v & "】"
　　　.Cells(1, 2).Resize(, UBound(mtxTemp, 2)).Value = Array("[項目]", "[グループ]")
　　　.Cells(2, 2).Resize(UBound(mtxTemp, 1), UBound(mtxTemp, 2)).Value = mtxTemp
　　End With
　Next

' ' 処理済後の「Dictionaryオブジェクト」後始末
　oDict.RemoveAll　' op１★　[Scripting]参照設定した場合 空に
'　Set oDict = Nothing　'　op２★ [Scripting]参照設定しない場合 解放
End Sub
　' '　ーーー

回答No.3

real beatin（@realbeatin）

こんにちは。

> A/B/Cそれぞれのグループの2次元配列を作成したい。
「なぜ二次元配列に格納する必要があるのか」
または
「二次元配列に格納した後でどのような処理をするのか」
とか、
「A/B/Cそれぞれのグループのグループ名（３種類）は常に固定なのか」
といった情報が不足していて、どう答えていいか難しいです。
> ... aryA ... aryB ... aryC
それぞれの変数の型は、
As Variant　なのか
As Variant()　なのか
As String()　なのか
説明に不備がありますので、As Variantでお応えしますが、
他の型だった場合には、手を加えないと動かないものしか書けません。
それでもまぁ出来ることはあると思って、実際に色々と書いてみる内に、
何かしらレスは書けるようになるかと試してみたのですが、
やはりもう少し具体性がないと考える事が多すぎて纏まりがつきません。
既に、コーディング（+コメント）で言えば800行超、設計の種類で20種超
書いてみましたが、お求めに副うような核心には至っていないのです。
そもそも、コーディングに関する質問（相談）という体ですが、
結局の所、全体的な設計の面で、まだ整理されていないような感じも受けます。

さしあたり３例だけ挙げてみます。

「A/B/Cそれぞれのグループのグループ名（３種類）は常に固定」
である場合について、
３つのVariant型変数（aryA, aryB, aryC）に
直接格納する例をひとまず、直接的な解答として、、、。
一応、配列に関しては、次元数や、最大・最少の添え字（サイズ）等は、
基本的に大事な情報ですので、必要十分な大きさを確保しなければなりません。
よく見かける方法としては、
行列を反転させた配列を受け皿に、X（第２次元）方向に拡張（ReDim Preserve）しながら、
格納して行って、最後に行列を再反転させるのが割と簡単ですが、
予めグループ名（３種類）が判っているのであれば、
ExcelのCountIf関数で数えてからReDimしておけば、より簡素に出来ます。

　' '　ーーー
' ' ReDim + CountIf -> Matrix
Sub Re_a1()　'　W9155487
Dim rngTable As Range
Dim aryKeys　'　「各グループ」名　一次元配列
Dim mtxSrc　'　「基テーブル」　二次元配列
Dim aryCnt　'　「各グループ」毎の カウント
Dim aryA, aryB, aryC　'　二次元配列　格納先
Dim i As Long, j As Long, p As Long

　aryKeys = VBA.Array("A", "B", "C")　'　要確認◆グループ名３種、正確に指定
　With Sheets("Sheet1")　'　要確認◆シート名？　With ActiveSheet？
　　Set rngTable = .Range("A2:B" & .Cells(Rows.Count, "B").End(xlUp).Row)
　End With
　mtxSrc = rngTable.Value　'　「基テーブル」まるごと二次元配列として格納

　ReDim aryCnt(UBound(aryKeys))
　For i = 0 To UBound(aryKeys)
　　aryCnt(i) = WorksheetFunction.CountIf(rngTable.Columns(2), aryKeys(i))
　Next i
　Set rngTable = Nothing

　ReDim aryA(1 To aryCnt(0), 1 To 2)
　ReDim aryB(1 To aryCnt(1), 1 To 2)
　ReDim aryC(1 To aryCnt(2), 1 To 2)
　ReDim aryCnt(UBound(aryKeys))

　For i = 1 To UBound(mtxSrc)
　　Select Case WorksheetFunction.Match(mtxSrc(i, 2), aryKeys) - 1
　　Case 0
　　　p = aryCnt(0) + 1
　　　aryA(p, 1) = mtxSrc(i, 1)
　　　aryA(p, 2) = mtxSrc(i, 2)
　　　aryCnt(0) = p
　　Case 1
　　　p = aryCnt(1) + 1
　　　aryB(p, 1) = mtxSrc(i, 1)
　　　aryB(p, 2) = mtxSrc(i, 2)
　　　aryCnt(1) = p
　　Case 2
　　　p = aryCnt(2) + 1
　　　aryC(p, 1) = mtxSrc(i, 1)
　　　aryC(p, 2) = mtxSrc(i, 2)
　　　aryCnt(2) = p
　　End Select
　Next i
' '　ーー 配列変数 格納処理　↑以上↑　ーー

' ' 処理例として　結果を新規シート上で確認する
　Worksheets.Add
　Range("A1:E1").Value = Array("【aryA】", , "【aryB】", , "【aryC】")
　Range("A2:B2,C2:D2,E2:F2").Value = Array("[項目]", "[グループ]")
　Range("A3").Resize(UBound(aryA), 2).Value = aryA
　Range("C3").Resize(UBound(aryB), 2).Value = aryB
　Range("E3").Resize(UBound(aryC), 2).Value = aryC
End Sub
　' '　ーーー

「A/B/Cそれぞれのグループのグループ名（３種類）は常に固定ではない」
場合の話かも知れませんし、そうでなくとも、備えたものを書けば、
汎用的に使えるようになりますから、以下は固定でなくても動くものについて。
（コードは次の投稿で掲げます）

ここで、
３つの配列変数（aryA, aryB, aryC）を、どう扱うのかという疑問について。
グループ名が"A"なら、変数aryA
グループ名が"B"なら、変数aryB
グループ名が"C"なら、変数aryC
という対応関係は解るのですが、元は同一のテーブルな訳ですから、
異なる目的に使うものではなさそうに見えます。
すると、変数を参照する際にも、"A"ならaryAみたいな記述を固定的に書く、
という設計になっているのでしょうか。
だとすると今度は、aryA(any,2)にわざわざひとつずつ"A"を格納しておく必要
が、どんな理由なのかも解り難いです。
外部のアプリケーションに配列を渡す場合でも、配列でなければならない、という
ことは滅多にないですし、
Excelシートに出力する為ならAdvancedFilterだけで片付きますから配列は不要ですし、、、。
私が想定したのは、
配列への参照を動的に（その配列を参照するか）変化させたい、
という要求についてです。
以下は、DictionaryオブジェクトのItemに配列を格納する例です。
格納が済んでしまえば、
　　oDict("aryA")　→　配列全体
　　oDict("aryA")(2,1)　→　"アボカド"
のように値を参照（取得のみ）できます。
　　aryA = oDict("aryA")
のようにすれば、配列aryAでは編集も可能になります。

Sub Re_c2()　では、
一旦、基テーブルをExcel一般機能でソートしてからの処理になります。
ソースの並びが案外に不規則でしたので、元の並びに戻す為に、
事前にＣ列に昇順のＩＤを設定してからの実行になります。
（例：C2=1,C3=2,C4=3,...,C22=21）

Sub Re_j3()　では、
ADODB.RecordsetのFilterプロパティで抽出結果としての配列を取得します。

先に挙げたSub Re_a1()はベタな総当たり判別でしたが、
「事前にソート」
または
「フィルターを用いる」
という過程を踏めば様々な方法で比較的簡単に書けるようになるかと思います。

Sub Re_j3()は外部オブジェクトを複数扱う分、記述は長めですが、
やってる内容は至ってシンプルなので、
仕様書も短文で済みますし、読む人にも理解され易く追加編集も容易、
という意味で、私の仕事でも実際に使っている手法です。
（xl2007以前では、使えなくもないですが問題あって薦められません）

要求も様々なら　方法も紹介し切れない程多彩　ですので、
お求めに適うものを提示できていないかもわかりませんけれど、
何かの参考にでもなれば幸いです。
設計の話抜きに配列の話を考えるのは、想定が拡がり過ぎて難しいので、
以後無理に答えを付けることもないかな、と思っていますので、ご理解を。
詳らかな補足や具体的な要求などもしあれば、またお応え出来るのかも、です。

　-> 次の投稿へつづきます。

回答No.2

Prome_Lin

最後の方、「For i = 1 to a」以降、「End Sub」の前までは、不要です。

プログラムが正しく動いたか、確認のため、エクセルに結果を出力しているだけの部分です。

正しく動いていることが確認できれば、削除しておいてください。

Option Explicit
Sub Test()
Dim aryA(9, 2), aryB(9, 2), aryC(9, 2) As String
Dim a, b, c, i As Integer
a = 0
b = 0
c = 0
For i = 2 To Range("A1").End(xlDown).Row
Select Case Cells(i, 2).Value
Case "A"
a = a + 1
aryA(a, 1) = Cells(i, 1).Value
aryA(a, 2) = Cells(i, 2).Value
Case "B"
b = b + 1
aryB(b, 1) = Cells(i, 1).Value
aryB(b, 2) = Cells(i, 2).Value
Case "C"
c = c + 1
aryC(c, 1) = Cells(i, 1).Value
aryC(c, 2) = Cells(i, 2).Value
End Select
Next i
For i = 1 To a
Cells(i, 4).Value = aryA(i, 1)
Cells(i, 5).Value = aryA(i, 2)
Next i
For i = 1 To b
Cells(i, 7).Value = aryB(i, 1)
Cells(i, 8).Value = aryB(i, 2)
Next i
For i = 1 To c
Cells(i, 10).Value = aryC(i, 1)
Cells(i, 11).Value = aryC(i, 2)
Next i
End Sub

回答No.1

imogasi

完成形の形を質問文内に例示するべきだ。なんのことかわからない。
ーー
まずグループ（記号）とはA,B,C,・・・のことか。
・結果としてシートに作るのか。
・シート上のセル範囲に、どういうにデータができれば（配列できれば）よいのか。
・シート上に表示するのではなく、プログラムのコーディング上に何かを作るのか。
ーー
エクセルのシートは２次元配列の体裁をしているが、２次元配列を作りたいとは言わないだろう。
シートから２次元配列に入れる課題はあり得る。プログラム実行中だけ有効のもの。
VBAをやるレベルにしては、何をしたいのかよく表現できていない。
ーー
VBAも経験が少なさそうだから、VBAを考えず、元データからこういう結果表？を作りたいといって、回答者に任せるのを勧めたい。
ーー
「リスト」とはエクセルでは、シートのデータのあり様をいう術語だ。シート上に出来上がったものをいうのだ。
ーー
プログラムなど使わず、ピボットテーブルなどは使って実現しないのか？