3×3マスの数字を横一列に並べて同じ数字を塗潰す

質問

いつもお世話になっております。
どなたかご存知の方がお見えでしたら回答をいただけると助かります。
【質問】
　添付図のとおりA1～K11の中に3×3マスが４つあります。
　それぞれ「左上赤枠」、「右上赤枠」、「左下赤枠」、「右下赤枠」とします。
　この中にある数字はバラバラで重複が有ります。
　この４枠の数字を左から昇順にしてN2～V5に出力します。
　その後、「左上赤枠」と「右上赤枠」、「左下赤枠」と「右下赤枠」を比べて
　同じ数字があれば黄色に塗り潰す方法が知りたいです。

【注意事項】
　　・A1～K11の中にある3×3の4つの枠の位置は常に固定です。
　　・使用するエクセルは2016です。
　※左下赤枠と右下赤枠の19が塗り潰しできてないのはただのミスです。
以上、よろしくお願いします。

回答No.1

Mathmi · ベストアンサー

VBAを使えば、以下の各機能を積み上げていくだけで作成できます。
・比較する値があるセル範囲を取得。
・そのセル範囲から値を取得。
・取得した値をソート。
・ソートした配列を出力。
・ソートした配列の各値を比較、同じならば相当するセルを着色する。
以下は、参考用に軽く組んでみたものです。
[GetInputRange]プロシージャの内容を変更する事で、何組でも比較できるようになります。また、3*3以外のセル範囲にも対応しています。

Option Explicit

Private Type Dat
　Input As range '値が入ったセル範囲。
　Ary() As Double '値を格納した配列。
End Type

Sub PairCheck()
　'値が入っているセル範囲を設定。
　Dim PairData() As Dat
　PairData = GetInputRange

　'セル範囲から値を取得してソート。
　Dim i As Long
　Dim cntMin As Long, cntMax As Long
　cntMin = LBound(PairData)
　cntMax = UBound(PairData)
　For i = cntMin To cntMax
　　Call SetSortValue(PairData(i))
　Next i

　'ソートした値を比較、指定範囲に出力。
　For i = cntMin To cntMax Step 2
　　Call OutputPair(Cells(i + 1, 14), PairData(i), PairData(i + 1))
　Next i
End Sub

Private Function GetInputRange() As Dat()
　'値が入っているセル範囲を設定。
　'必ず偶数にする事。
　Dim D() As Dat
　ReDim D(1 To 4)
　Set D(1).Input = Cells(2, 2).Resize(3, 3)
　Set D(2).Input = Cells(2, 8).Resize(3, 3)
　Set D(3).Input = Cells(8, 2).Resize(3, 3)
　Set D(4).Input = Cells(8, 8).Resize(3, 3)
　GetInputRange = D
End Function

Private Sub SetSortValue(D As Dat)
　Dim i As Long, cnt As Long
　cnt = D.Input.Count

　'セル範囲から値を取得。
　ReDim D.Ary(1 To cnt)
　For i = 1 To cnt
　　D.Ary(i) = D.Input(i)
　Next i

　'取得した値をソート。
　D.Ary = BubbleSort(D.Ary)
End Sub

Private Function BubbleSort(argAry() As Double) As Double()
　'バブルソート
　Dim vSwap As Variant
　Dim i As Long
　Dim j As Long
　For i = UBound(argAry) To LBound(argAry) Step -1
　　For j = LBound(argAry) To i - 1
　　　If argAry(j) > argAry(j + 1) Then
　　　　vSwap = argAry(j)
　　　　argAry(j) = argAry(j + 1)
　　　　argAry(j + 1) = vSwap
　　　End If
　　Next j
　Next i
　BubbleSort = argAry
End Function

Private Sub OutputPair(baseCell As range, Dat1 As Dat, Dat2 As Dat)
　'エラーチェック
　If Dat1.Input.Count <> Dat2.Input.Count Then
　　MsgBox "比較する2つのセル範囲の大きさが異なります。"
　　End
　End If

　'値を出力。
　Dim cnt As Long
　cnt = Dat1.Input.Count
　baseCell.Offset(0, 0).Resize(1, cnt) = Dat1.Ary
　baseCell.Offset(1, 0).Resize(1, cnt) = Dat2.Ary

　'値を比較して着色。
　Dim i As Long, j As Long
　For i = 1 To cnt
　　For j = 1 To cnt
　　　If Dat1.Ary(i) = Dat2.Ary(j) Then
　　　　baseCell.Offset(0, i - 1).Interior.Color = RGB(255, 255, 153)
　　　　baseCell.Offset(1, j - 1).Interior.Color = RGB(255, 255, 153)
　　　End If
　　Next j
　Next i
End Sub

お礼

早速回答頂きありがとうございます。
また、ロジックの考え方と処理中のコメントをつけて頂き勉強になりました。
やりたいことができました。
ありがとうございました。

回答No.3

kkkkkm

添付画像のセル位置で決め打ち的に

Sub Test()
Dim i As Long, j As Long, k As Long, m As Long, n As Long
Dim mRange As Variant
Dim mRow As Long: mRow = 2
Dim c As Range, FRange As Range

Range("N2:V5").Interior.ColorIndex = xlNone
For i = Range("B2").Row To Range("H8").Row Step (Range("H8").Row - Range("B2").Row)
For j = Range("B2").Column To Range("H2").Column Step (Range("H2").Column - Range("B2").Column)
Set mRange = Range(Cells(i, j), Cells(i, j).Offset(3, 3))
n = 0
For k = 1 To 3
For m = 1 To 3
Cells(mRow, Cells(mRow, "N").Column + n).Value = mRange(k, m).Value
n = n + 1
Next
Next
Range(Cells(mRow, "N"), Cells(mRow, "V")).Sort _
Key1:=Cells(mRow, "N"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlSortRows, _
SortMethod:=xlPinYin
mRow = mRow + 1
Next
Next
For i = 2 To 4 Step 2
For Each c In Range(Cells(i, "N"), Cells(i, "V"))
Set FRange = Range(Cells(i + 1, "N"), Cells(i + 1, "V")).Find(c.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not FRange Is Nothing Then
c.Interior.Color = vbYellow
FRange.Interior.Color = vbYellow
End If
Set FRange = Nothing
Next
Next
End Sub

お礼

いつもお世話になっております。
マス固定だとこのようなＶＢＡになるのですね。
ありがとうございました。

回答No.2

imogasi

VBAと「エクセルの条件付き書式設定の操作」の組み合わせでやってみた。
（１）マスの範囲をマウスで選択。
（２）下記説明のボタンをクリック
（３）Ｈ－Ｐ列にセルに、各マスのデータがよこ１列に並べられる。
（４）条件を満たしたセルに色が着く
（５）これをマスごとに繰り返す。
ーーー
データのあるシートをＳｈｅｅｔ１とする。
そのシートにコマンドボタンを１つ貼り付け
そのボタンのクリックイベントように、標準モジュールに
Sub test01()
j = 8 'H列から
r = Range("H100000").End(xlUp).Row + 1
For Each cl In Selection
Cells(r, j) = cl
j = j + 1
Next
End Sub
ーー
Ｓｈｅｅｔ１のシートモジュールに
Private Sub CommandButton1_Click()
test01
End Sub
Ｓｈｅｅｔ１のＨ１：Ｐxを範囲指定して（ｘは適当な行数字を示す）
ホームー条件付き書式ー新しいルールー数式を使用して・・
数式は　=COUNTIF($H1:$P1,H1)>=2
＄の付いてないところは、そのまま付けないようにするように注意。
書式は、塗りつぶしの黄色（お好みで）。

お礼

いつもお世話になっております。
別回答をいただきありがとうございます。
全てＶＢＡでなくてもできるのですね。
今の私にはちょっと難しいです。
ありがとうございました。