n個中規定数取出すを繰返すVBA

質問

excel2013において、
16組のx,yが9組あり、その16組から6個取り出し、次の16組からも6個取り出すのを繰り返します。
取り出した合計54組のx,yの相関係数のうち、最大値とその組み合わせた54組の行番号を表示させるVBAをご教示ください。
データは、xがA1～A144に、yがB1～B144に入っています。

全ての組み合わせでx,yの相関係数を求めると513,537,536,512個の相関係数が得られますが、このデータは必要ありません。

回答No.8

Mathmi

＞WorksheetFunctionクラスのPearsonプロパティを取得できません。
引数が適切でなかった場合、このエラーが出るようです。
こちらで、全て白紙のシートで試してみた(X配列及びY配列がすべて0)所、同じエラーが出ました。

このエラーが出た時、相関係数を導く元の値がどうなっているのか、一度確認してみて下さい。

補足

回答ありがとうございます。
適切な引数というのがとても難しいです。
A列もB列も全て1の場合、相関係数も1としてメッセージウィンドウが出ます。
そのうちの一部をかけ離れた値にすると同じエラーになりました。
また、今回求めたいデータを与えても同じエラーです。
書式を含め、もう少し読んでみます。

回答No.7

masnoske

nCr の一覧表を作成する汎用マクロを組もうと思ったのですが、難しいですね。
とりあえず、16C6 の一覧表を作成するマクロを作ってみました。
手を加えれば、望んでおられる最大値を得られるマクロができると思います。
あるいは、一覧表だけ作って、残りの作業はワークシート関数で対応するのも良いと思います。

汎用化できればいいんですが。。。

Sub Comb()
Dim n As Long: n = 16
Dim r As Long: r = 6

Dim d1 As Variant
Dim d2 As Variant
Dim d3 As Variant
Dim d4 As Variant
Dim d5 As Variant
Dim d6 As Variant

ReDim d1(n) As Long
ReDim d2(n) As Long
ReDim d3(n) As Long
ReDim d4(n) As Long
ReDim d5(n) As Long
ReDim d6(n) As Long

Dim i1 As Long
Dim i2 As Long
Dim i3 As Long
Dim i4 As Long
Dim i5 As Long
Dim i6 As Long

Dim rw As Long

rw = 0
For i1 = 1 To n - r + 1
For i2 = i1 + 1 To n - r + 2
For i3 = i2 + 1 To n - r + 3
For i4 = i3 + 1 To n - r + 4
For i5 = i4 + 1 To n - r + 5
For i6 = i5 + 1 To n - r + 6
rw = rw + 1
Cells(rw, 1) = i1
Cells(rw, 2) = i2
Cells(rw, 3) = i3
Cells(rw, 4) = i4
Cells(rw, 5) = i5
Cells(rw, 6) = i6
Next
Next
Next
Next
Next
Next
End Sub

回答No.6

Mathmi

前回の続き。
ある配列から指定の数抜き出した全ての場合を列挙するプロシージャです。

Private Function CombineCases(ary As Variant, n As Long) As Variant()
　''' <summary>
　''' 配列からN個の値を抜き出した全ての場合を列挙する。
　''' </summary>
　''' <param name="Ary">抜き出す配列。arrayで設定すると想定し、配列とはしていない。</param>
　''' <param name="N">抜き出す要素数。</param>
　''' <returns>全パターンを格納したvariant配列。</returns>
　''' <remarks>備考</remarks>
　Dim i As Long, cnt As Long
　Dim aryComb() As Variant '抽出元配列。
　Dim aryResult() As Variant '抽出先配列。
　Dim aryContainer() As Variant '抽出した各配列を格納する配列。

　'組み合わせを取り出す配列を1から開始する配列に変換する。
　cnt = UBound(ary) - LBound(ary) + 1
　ReDim aryComb(1 To cnt)
　For i = 1 To cnt
　　aryComb(i) = ary(LBound(ary) + i - 1)
　Next i

　'取り出した配列を格納する配列を作成する。
　ReDim aryContainer(1 To WorksheetFunction.Combin(UBound(aryComb), n))
　ReDim aryResult(1 To n)

　'再帰
　Call CombineCasesSingle(aryComb, aryContainer, aryResult, 0, 1, 1)
　CombineCases = aryContainer
End Function

Private Sub CombineCasesSingle(aryComb() As Variant, aryContainer() As Variant, aryResult() As Variant, cntAry As Long, numStart As Long, numIndex As Long)
　''' <summary>
　''' 元の配列から1個抜き出し、抜き出す配列に格納する。
　''' aryResultに全て格納されたなら、その配列をaryContainerに格納する。
　''' aryResultに全て格納されていないなら再帰する。
　''' </summary>
　''' <param name="aryComb()">組み合わせを抜き出す配列。</param>
　''' <param name="aryContainer()">抜き出した組み合わせを格納する配列。</param>
　''' <param name="aryResult()">現在抜き出している配列。</param>
　''' <param name="cntAry">現在格納しているaryContainerの要素数。</param>
　''' <param name="numStart">aryCombの何番目の要素から抜き出すか。</param>
　''' <param name="numIndex">抜き出したものをaryResultの何番目の要素に入れるか。</param>
　''' <remarks>備考</remarks>
　Dim i As Long
　Dim cntResult As Long '格納後の残り抜き出し数。

　cntResult = UBound(aryResult) - numIndex
　If cntResult = 0 Then
　　'全て抜き出し切ったならばcollectionに格納して終了。
　　For i = numStart To UBound(aryComb)
　　　aryResult(numIndex) = aryComb(i)
　　　cntAry = cntAry + 1
　　　aryContainer(cntAry) = aryResult
　　Next i
　ElseIf UBound(aryComb) - cntResult >= numStart Then
　　'まだ抜き出し切っていないならば、次の値を抜き出す為に再帰。
　　For i = numStart To UBound(aryComb) - cntResult
　　　aryResult(numIndex) = aryComb(i)
　　　Call CombineCasesSingle(aryComb, aryContainer, aryResult, cntAry, i + 1, numIndex + 1)
　　Next i
　Else
　　'エラートラップ
　　Stop
　End If
End Sub

お礼

回答ありがとうございます。
まだ全部読めてはいませんが、相関係数だけを出力しているのでしょうか？
最大値を示した生データ54個も出力して頂きたいのです。

回答No.5

Mathmi

＞ただし、1354溝を超えるデータ数を逐次処理させるのは、
＞アルゴリズム的に効率的と言えるのか疑問ではあります。
　ご指摘の通り、エクセルで総当たりさせるのは、余程効率的にアルゴリズムを組まない限り無理だと思います。
　全パターンを愚直に計算して最大値を求めるのは、恐らく無理でしょう。

　一応、もっと数が少ない場合に役立つかもと、力業で総当たりさせるプロシージャを作ってみました。
　全ての組み合わせを列挙するプロシージャは、他でも流用できそうでしたし。
　流れとしては以下のようなものです。
　・16個の(x,y)を1セットとし、2セットを取得。
　・1～16から2個を抜き出す全パターンを取得。
　・それぞれのセット毎に、抜き出すパターンを当てはめる。
　・全セットにパターン番号が割り振られたら、その番号に従って計算用配列を作る。
　・作った配列から相関係数を計算する。
　・今まで計算した相関関数よりも大きければ、その値に差し替える。
　・全パターンに対して繰り返す。

　文字数が多すぎて1回では入りきらなかったので、2回に分けます。

Option Explicit

Private Type BasePair
　Range As Range
　BaseAry() As Double
　numPattern As Long
End Type

Sub GetMaxPearson()
　Dim i As Long

　'元となる配列を格納する。
　Dim B() As BasePair
　ReDim B(1 To 2)
　For i = 1 To 2
　　B(i) = GetBasePair(Cells((i - 1) * 16 + 1, 1).Resize(16, 2), 6)
　Next i

　'16個の中から2個取り出すパターンをすべて抜き出す。
　Dim aryPattern() As Variant
　aryPattern = CombineCases(Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16), 2)

　'全ての相関関数を計算、最大値を求める。
　Dim MaxPearson As Double
　MaxPearson = -1
　Call GetMaxPeason(B, aryPattern, 1, MaxPearson)
　MsgBox MaxPearson
End Sub

Private Function GetBasePair(Target As Range, Num As Double) As BasePair
　'大元の配列を取得。
　Dim i As Long, j As Long
　'セル範囲を取得。
　Dim rtn As BasePair
　Set rtn.Range = Target
　'セル範囲から値を取得。
　Dim myRow As Long, myCol As Long
　myRow = rtn.Range.Rows.Count
　myCol = rtn.Range.Columns.Count
　ReDim rtn.BaseAry(1 To myRow, 1 To myCol)
　For i = 1 To myRow
　　For j = 1 To myCol
　　　rtn.BaseAry(i, j) = rtn.Range(i, j).Value
　　Next j
　Next i
　GetBasePair = rtn
End Function

Private Function GetMaxPeason(B() As BasePair, aryPattern() As Variant, numIndex As Long, MaxPearson As Double) As Double
　'総当たりで最大の相関係数を返す。
　Dim i As Long, cnt As Long, buf As Double
　Dim X() As Double, Y() As Double

　If numIndex = UBound(B) Then
　　'その場合分けパターン数を設定し、最後のセットでない場合相関係数を求める。
　　For i = 1 To UBound(aryPattern)
　　　B(numIndex).numPattern = i
　　　'相関係数算出用配列を取得。
　　　Call GetPeasonAry(B, aryPattern, X, Y)
　　　'相関係数を計算。
　　　buf = WorksheetFunction.Pearson(X, Y)
　　　'算出した相関係数は既存のものより大きければ、それに差し替える。
　　　If MaxPearson < buf Then
　　　　MaxPearson = buf
　　　End If
　　Next i
　Else
　　'その場合分けパターン数を設定し、最後のセットでない場合次のセットに移る。
　　For i = 1 To UBound(aryPattern)
　　　B(numIndex).numPattern = i
　　　Call GetMaxPeason(B, aryPattern, numIndex + 1, MaxPearson)
　　Next i
　End If
End Function

Private Sub GetPeasonAry(B() As BasePair, aryPattern() As Variant, X() As Double, Y() As Double)
　'元の配列から、指定された組み合わせパターンに従って抜き出した値を集めた配列を作る。
　Dim i As Long, j As Long, cnt As Long
　cnt = UBound(B) * UBound(aryPattern(B(1).numPattern))
　ReDim X(1 To cnt)
　ReDim Y(1 To cnt)
　cnt = 0
　For i = 1 To UBound(B)
　　For j = 1 To UBound(aryPattern(B(i).numPattern))
　　　cnt = cnt + 1
　　　X(cnt) = B(i).BaseAry(aryPattern(B(i).numPattern)(j), 1)
　　　Y(cnt) = B(i).BaseAry(aryPattern(B(i).numPattern)(j), 2)
　　Next j
　Next i
End Sub

以下続く。

補足

回答ありがとうございます。
とりあえずVBAのGeneralにペーストして実行してみました。
すると
buf = WorksheetFunction.Pearson(X, Y)
この行で
WorksheetFunctionクラスのPearsonプロパティを取得できません。
で停止してしまいました。
まだちゃんとプログラムを読み込んではいないので、取り急ぎ。
頑張って読んでみます。

回答No.4

masnoske

16C6 の組み合わせ表の作り方ですが、以下のURLが参考になります。
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q12120942937

ここでは、nCr(n<=7) までの表ですが、H列をQ列まで、128行を65536行まで拡張すればn<=16までの組み合せ表ができます。

組み合わせ表ができたら、以下のような処理方法を考えてみました。
1.元データを第1郡～第9郡の9枚のシートに分けて処理し、各シートのCORRELの最大値を求める。
2.各シートの最大値の中から最大値を選ぶ。

実際には第1郡のシートだけ作成し、コピーすれば良いかと思います。

補足

回答ありがとうございます。
しかし、これでは各群内での相関係数を求めることになってしまいます。

必要なのは各群から6組ずつ取り出した計54組の相関係数です。
8008 * 9 = 72072 個の相関係数の中から最大値を求めるわけではありません。
8008 ^ 9 ≒ 1.35e+35 個の相関係数の中から最大値を求めたいのです。

回答No.3

masnoske

勘違いしていました。
サンプリングではなく、全ての相関係数を計算して、その中の最大値を求めるのですね。

16組から重複せずに9組を選ぶ組み合わせは
16C6 = 16! / 6! / (16 - 6)!
= (16*15*14*13*12*11)/(6*5*4*3*2*1)
= 8008

これが9組ありますから、
8008 * 9 = 72072 個の相関係数の中から最大値を求めると理解しました。

ここまでは合っていますか？

補足

回答ありがとうございます。
16組 × 9組なので、生データは総計144組です。
この9組は互いに独立していますから、
8008 ^ 9 ≒ 1.35e+35 パターンあると愚考いたしました。
（本文中などにある513537536512は8008^3で、私の計算ミスです。これでは3組ですね）
ただし、1354溝を超えるデータ数を逐次処理させるのは、
アルゴリズム的に効率的と言えるのか疑問ではあります。

もし、この9組が関連がある、
つまり、1組目のデータと17組目、33組目・・・129組目がセットになっている、(16n-15)
次は16n-14組目がセット、以下同様、の場合には
8008パターンで済むわけですが。
こちらに関しましては、これはこれで需要があるので、
別件とは成りますが、全パターンexcelに書き出させるという力業で解いてみたいと思っています。

回答No.2

masnoske

１６組の組データから重複せずに６組をランダム抽出するのが悩みどころかと思います。
こちらのURLにその方法が紹介されています。
http://office-qa.com/Excel/ex205.htm

ここで抽出するのは、データの組ではなく、データが入力されている行番号とします。
ランダム抽出した行番号からINDIRECT関数で該当するデータの組をグループごとに書き出し、それぞれのグループの相関係数をCORREL関数で求めます。
あとは、相関係数の最大値をMAX関数で求めます。

データの組から該当する行を探すのではなく、先にランダムに行を抽出してから該当するデータ組で相関係数を計算するという考え方です。

補足

回答ありがとうございます。
INDIRECT関数で該当するデータの組をグループごとに書き出す、とのことですが、
書き出すセルとして513537536512列が必要になるかと思います。
これは単純にexcelに処理可能な列数なのでしょうか？

また、必ずしもランダムに抽出する必要はなく、全通りを検証する必要があると思いますが、
第1試行目の相関係数と第2試行目の相関係数を比較し、大きい方を採用し、
さらにそれを第3試行目と比較し、大きい方を採用し・・・と繰り返していって、
第513537536512試行目まで行うと、最大値が得られるという考え方をしていましたが、
このアルゴリズムは適切でしょうか？
ただ、このアルゴリズムをプログラミングする能力がありません。
ご教示願えれば幸いです。

回答No.1

masnoske

まず、ワークシート関数だけでできる作業をVBAでする必要があるのかどうかを検討されたほうが良いと思います。

どうしてもVBAでというのなら、作成されたコードを開示されたほうが回答してもらいやすいと思います。

VBAとは関係ありませんが、相関係数の最大値を求めたいということは、正の相関だけが必要で、負の相関は不要ということでしょうか。

補足

回答ありがとうございます。
不勉強のためVBAが必要と考えておりました。
ワークシート関数を使用した具体的な作業方法をご教示願えれば幸いです。
相関係数は正が想定されているデータです。
また、データは1～16が第1群、17～32が第2群、以下同様です。