共通の値を持つ座標の組み合わせについて

質問

• 共通の値を持つ座標の組み合わせを表示するVBAの作成方法について考えています。
• 表の特定の座標に共通の値を持つ組み合わせを表示するVBAを作成したいです。
• VBAに詳しい方からのアドバイスを頂けると助かります。

回答No.13

_Kyle

#11です。

#12さまのおっしゃるとおり、元データの並びによっては
シートに何もなくても時間がかかる場合がありますね。
早合点の怪答で大変失礼いたしました。
----------------------
お詫びというわけでもないんですが
オリジナルコードを。(^^;;;;;;;

まったく胡乱なコードで、
自分でも何やってるのか混乱気味ですが
ダミーデータで何度かテストした感じでは
#12さまのコードと同じ解が返るようです。

※チェックのため
　結果は【Sheet3】に返す仕様にしています。

ご参考まで。長乱コード陳謝。

'--------↓　ココカラ　↓------------------------
Option Base 1
'Declare Function timeGetTime Lib "winmm.dll" () As Long

'宣言----------------------------------
Const mySiz As Long = 150

　Private myDat(mySiz, mySiz) As Boolean
　Private rsAry()　　　　　　 As Boolean
　Private ckAry(mySiz)　　　　As Long
　Private psAry(mySiz)　　　　As Long
　Private anAry(100000)　　　 As Variant
　Private rsCnt　　　　　　　 As Long
　Private rtCnt　　　　　　　 As Long
'　Private c　　　　　　　　　 As Long

'親Ｐ----------------------------------
Sub Sample_9()　　　'←お察しください^^;;;;

　'宣言----------------------
　Dim orSht As Worksheet
　Dim rtSht As Worksheet
　Dim ckFlg As Boolean
　Dim i　　 As Long
　Dim j　　 As Long
　Dim k　　 As Long
'　Dim t　　 As Long

　'初期化--------------------
　Erase myDat, ckAry, anAry, psAry
　ReDim rsAry(mySiz)
　rtCnt = 0
　rsCnt = 0
'　t = timeGetTime
'　c = 0

　Set orSht = Worksheets("Sheet1")　'元表シート
　Set rtSht = Worksheets("Sheet3")　'結果シート

　'読込----------------------
　For i = 1 To mySiz - 1
　　For j = i + 1 To mySiz
　　　myDat(i, j) = orSht.Cells(i + 1, j + 1).Value = 1
　　　myDat(j, i) = myDat(i, j)
　　Next j
　Next i

　'準備----------------------
　For i = 1 To mySiz
　　ckFlg = False
　　For j = 1 To mySiz
　　　If myDat(i, j) Then
　　　　ckFlg = True
　　　　Exit For
　　　End If
　　Next j
　　rsAry(i) = ckFlg
　Next i

　'探索----------------------
　Call Sample_s(0, 0, mySiz)

　'書出----------------------
　If rtCnt > 0 Then
　　Call Sample_d(rtSht)
　End If

　'終了----------------------
　Application.StatusBar = False
　Erase myDat, rsAry, ckAry, anAry, psAry
'　Debug.Print timeGetTime - t, c, rtCnt

End Sub

'子Ｐ----------------------------------
Private Sub Sample_s( _
　ByVal itCnt As Long, _
　ByVal psCnt As Long, _
　ByVal lsCnt As Long _
　)

'　c = c + 1

　'宣言----------------------
　Dim tpAry()　As Boolean
　Dim ckFlg　　As Boolean
　Dim i　　　　As Long
　Dim j　　　　As Long
　Dim k　　　　As Long

　'主処理？------------------
　　'何やってんだか最早自分でも…　orz

　For i = itCnt + 1 To lsCnt
　　If rsAry(i) Then
　　　rsCnt = rsCnt + 1
　　　ckAry(rsCnt) = i
　　　tpAry = rsAry
　　　ckFlg = True
　　　If i < mySiz Then
　　　　k = i + 1
　　　End If
　　　For j = i + 1 To lsCnt
　　　　If rsAry(j) Then
　　　　　If Not myDat(i, j) Then
　　　　　　rsAry(j) = False
　　　　　　ckFlg = False
　　　　　Else
　　　　　　k = j
　　　　　End If
　　　　End If
　　　Next j
　　　Call Sample_s(i, psCnt, k)
　　　rsAry = tpAry
　　　rsCnt = rsCnt - 1
　　　If ckFlg Then Exit Sub
　　　rsAry(i) = False
　　　psCnt = psCnt + 1
　　　psAry(psCnt) = i
　　End If
　Next i

　'チェック------------------
　For i = 1 To psCnt
　　ckFlg = True
　　For j = 1 To rsCnt
　　　If Not myDat(ckAry(j), psAry(i)) Then
　　　　ckFlg = False
　　　　Exit For
　　　End If
　　Next j
　　If ckFlg Then Exit Sub
　Next i

　'ヒット--------------------
　rtCnt = rtCnt + 1
　anAry(rtCnt) = rsAry
　If rtCnt Mod 100 = 1 Then
　　Application.StatusBar = rtCnt & "件"
　End If

End Sub

'書出Ｐ--------------------------------
Private Sub Sample_d(ByRef rtSht As Worksheet)

　'宣言----------------------
　Dim dpAry() As Variant
　Dim i　　　 As Long
　Dim j　　　 As Long
　Dim k　　　 As Long

　ReDim dpAry(rtCnt, mySiz)

　Application.StatusBar = "書き出し中"

　'書出配列------------------
　For i = 1 To rtCnt
　　k = 1
　　rsAry = anAry(i)
　　For j = 1 To mySiz
　　　If rsAry(j) Then
　　　　dpAry(i, k) = j
　　　　k = k + 1
　　　End If
　　Next j
　Next i

　'書出----------------------
　Application.Calculation = xlCalculationManual
　Application.ScreenUpdating = False
　With rtSht
　　rtSht.Cells.ClearContents
　　rtSht.Cells(2, 2).Resize(rtCnt, mySiz).Value = dpAry
　End With
　Application.Calculation = xlCalculationAutomatic

End Sub
'--------↑　ココマデ　↑------------------------

お礼

プログラムコードありがとうございます。

実際に試しましたら、10分程度で終わりました。すごいと感じました。1の数およびパターンによって状況が変わるようですので、回答者様のアドバイスを参考に１の配置を割り振っていこうと思います。

ちなみに、Private anAry(100000)の中の数値を変化させることで出力できる件数が変えられるということでしょうか？

一応Private anAry(200000)にするとインデックスが有効範囲にありませんの表示がなくなったので伺いました。注意点などあれば教えていただけるとありがたいです。