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

質問

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

回答No.3

nag0720

きれいなコードではないですが、次のようになります。

Sub test()
Dim TBL1(10) As Integer
Dim TBL2(10) As Integer

n = 0
For i = 1 To 9
m = 0
TBL1(m) = i
TBL2(m) = i
For j = i + 1 To 10
If Cells(i + 1, j + 1) = 1 Then
m = m + 1
TBL1(m) = j
TBL2(m) = j
End If
Next
Do
Flag = False
For k = 1 To m
If TBL2(k) > 0 Then
Flag = True
Exit For
End If
Next
If Not Flag Then Exit Do

Flag = True
For k1 = 1 To m - 1
For k2 = k1 + 1 To m
If TBL2(k1) > 0 And TBL2(k2) > 0 Then
If Cells(TBL2(k1) + 1, TBL2(k2) + 1) = 0 Then
Flag = False
Exit For
End If
End If
Next
If Not Flag Then Exit For
Next

If Flag Then
For p = 1 To n
Flag2 = True
For k = 0 To m
If TBL2(k) > 0 Then
Flag3 = False
For j = 1 To Worksheets("Sheet2").Cells(p + 1, 1)
If Worksheets("Sheet2").Cells(p + 1, j + 1) = TBL2(k) Then
Flag3 = True
Exit For
End If
Next
If Not Flag3 Then
Flag2 = False
Exit For
End If
End If
Next
If Flag2 Then
Flag = False
Exit For
End If
Next
End If

If Flag Then
n = n + 1
j = 0
For k = 0 To m
If TBL2(k) > 0 Then
j = j + 1
Worksheets("Sheet2").Cells(n + 1, j + 1) = TBL2(k)
End If
Next
Worksheets("Sheet2").Cells(n + 1, 1) = j
End If

k = m
Do While k > 0
If TBL2(k) > 0 Then
TBL2(k) = 0
Exit Do
Else
TBL2(k) = TBL1(k)
k = k - 1
If k <= 0 Then Exit Do
End If
Loop
Loop
Next
For p = 1 To n
Worksheets("Sheet2").Cells(p + 1, 1) = ""
Next
End Sub

なお、Sheet2のA列を作業用に使用しています。（最後に消去しています）
もしA列が使えない場合は他の列に変更してください。

結果は、
1　2　5　7
1　5　7　8
3　7
4　5　7
5　8　10
7　8　9
となりました。

質問の図の右側の結果には「1　5　7　8」と「5　8　10」がありませんが、これは組み合わせとして成立していないんでしょうか？

お礼

ご回答いただきましてありがとうございました。
質問の「5　8　10」がありませんが、これは組み合わせとして成立していないんでしょうか？
というものですが、成立します。目で追ってると抜け落ちてしまうところがありました。

ちなみに、今回は10行×10列ですが、これが100行×100列になる場合や左図の表の中の値１が多くなると、プログラム開始から終了までの時間は長くなりますか？アドバイスいただけますとありがたいです。