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

質問

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

回答No.17

_Kyle

#11,13,15,16です。

#16の続きです。
親と同じモジュールに記述してください。

'--------↑ツヅク↑------------------

'チェック----------
Private Sub Sample_c()

　Dim ckFlg As Boolean
　Dim i　　 As Long
　Dim j　　 As Long

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

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

End Sub

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

　'宣言-------
　Dim dpTbl() As Variant
　Dim tpTbl() As Boolean
　Dim mxCnt　 As Long
　Dim i　　　 As Long
　Dim j　　　 As Long
　Dim k　　　 As Long

　Application.StatusBar = "書き出し中"

　'並び調整---
　ReDim tpTbl(rtCnt, tbSiz)
　mxCnt = 0
　For i = 1 To rtCnt
　　k = 0
　　rsAry = rtAry(i)
　　For j = 1 To tbSiz
　　　If rsAry(j) Then
　　　　k = k + 1
　　　　tpTbl(i, odAry(j)) = rsAry(j)
　　　End If
　　Next j
　　If mxCnt < k Then mxCnt = k
　Next i

　'書出配列---
　ReDim dpTbl(rtCnt, mxCnt)
　For i = 1 To rtCnt
　　k = 0
　　For j = 1 To tbSiz
　　　If tpTbl(i, j) Then
　　　　k = k + 1
　　　　dpTbl(i, k) = j
　　　End If
　　Next j
　Next i

　Application.Calculation = xlCalculationManual
　Application.ScreenUpdating = False

　'書出-------
　With rtSht
　　.Select
　　.Cells.ClearContents
　　.Cells(2, 2).Resize(rtCnt, mxCnt).Value = dpTbl
　End With

　'出順調整---
　mxCnt = ((mxCnt - 1) \ 3 + 1) * 3
　With rtSht.Cells(2, 2).Resize(rtCnt, mxCnt)
　　For i = mxCnt To 3 Step -3
　　　.Sort _
　　　　key1:=.Cells(1, i - 2), _
　　　　order1:=xlAscending, _
　　　　key2:=.Cells(1, i - 1), _
　　　　order2:=xlAscending, _
　　　　key3:=.Cells(1, i), _
　　　　order2:=xlAscending
　　Next i
　End With

　Application.Calculation = xlCalculationAutomatic

End Sub

'ソート------------
Private Sub Sample_s( _
　ByVal lvIdx As Long, _
　ByVal lvOdr As Long, _
　ByVal mnIdx As Long, _
　ByVal mxIdx As Long)

　Dim tpVrb　　 As Long
　Dim loCnt　　 As Long
　Dim upCnt　　 As Long
　Dim loIdx　　 As Long
　Dim upIdx　　 As Long
　Dim i　　　　 As Long
　Dim j　　　　 As Long

　If mnIdx >= mxIdx Then Exit Sub

　'両端確定---
　loCnt = tbSiz
　loIdx = mnIdx
　upCnt = 0
　upIdx = mxIdx
　For i = mnIdx To mxIdx
　　If ctAry(odAry(i)) >= upCnt Then
　　　upCnt = ctAry(odAry(i))
　　　upIdx = i
　　End If
　　If ctAry(odAry(i)) <= loCnt Then
　　　loCnt = ctAry(odAry(i))
　　　loIdx = i
　　End If
　Next i

　tpVrb = odAry(mxIdx)
　odAry(mxIdx) = odAry(upIdx)
　odAry(upIdx) = tpVrb

　tpVrb = odAry(mnIdx)
　odAry(mnIdx) = odAry(loIdx)
　odAry(loIdx) = tpVrb

　'ソート-----
　i = mnIdx
　j = mxIdx

　Do
　　Do
　　　i = i + 1
　　　If i = mxIdx Then Exit Do
　　Loop While orTbl(odAry(lvIdx), odAry(i)) = False
　　Do
　　　j = j - 1
　　　If j = mnIdx Then Exit Do
　　Loop While orTbl(odAry(lvIdx), odAry(j)) = True

　　If j <= i Then Exit Do
　　tpVrb = odAry(i)
　　odAry(i) = odAry(j)
　　odAry(j) = tpVrb
　Loop

　'次の階へ---
　i = i - 1
　If mnIdx + 1 < i And i < mxIdx Then
　　Call Sample_s(lvIdx + lvOdr, lvOdr, mnIdx + 1, i)
　End If
　j = j + 1
　If mnIdx < j And j < mxIdx - 1 Then
　　Call Sample_s(lvIdx + lvOdr, lvOdr, j, mxIdx - 1)
　End If

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

■追記

もし、わたしの回答が、
課題を解決する上でいくらかでもお役に立てたなら
たいへんうれしく思いますが、

「横入り」とか「後出し」の是非はまた別の問題でして^^;;;;
締切りの際は【くれぐれもお間違えのないよう】
重ねてお願いします。　<(_ _)>

お礼

コメントが遅くなりまして申し訳ありません。excel2007が入っているパソコンをしばらくの間使用することができなかったために、プログラムを動かすことができなかったためです。実際にexcel2007にてプログラムを動かしましたら、3分程度で出力ができました。ありがとうございました。

ひょっとしたらこの件で、また伺いたいこっとがあるかもしれません。その場合に改めてアドバイスを頂けますと幸いです。よろしくお願いします。

余談ですがベストアンサーが１件しか選ぶことができないのが、つらいです。

補足

久しぶりに書き込みをします。新たに質問をさせてください。

パターン数がエクセル2007の最大行数である104万8576行を超える場合に、
新たに列を変えて続きを出力させることはできますでしょうか？

返信頂けますとありがたいです。よろしくお願いします。