- ベストアンサー
5×6マス検索→5×5マス検索への改造の仕方
- 5×6マスを5×5マスに変更する方法について質問です。検索値と同じ値か、隣接数字との差が0か1なら塗潰す方法がある。
- 具体的な5×5マスの配置が4つあり、それぞれの配置に対して同じ塗潰し方法を適用する。
- 5×7マスでも同様の塗潰し方法が適用できるかもしれない。
- みんなの回答 (2)
- 専門家の回答
質問者が選んだベストアンサー
>できれば、5×7マスが4つのケースも 複写数はQ1セル、検索値セルはQ2セルより右へ としています。 Sub Test2() Dim i As Long, myArea As Range Dim myRang As Range, c As Range Dim SV As Long, cc As Range, flg As Boolean Application.ScreenUpdating = False '作業行挿入 Rows("1:1").Insert '作業列挿入 Columns("A:A").Insert Range("B13:P528").Clear '【ここが変更】 For i = 1 To Range("R2").Value '【ここが変更】 Range("B2:P12").Copy Cells(i * 12 + 2, "B") '【ここが変更】 Set myArea = Cells(i * 12 + 2, "B").Resize(11, 15).SpecialCells(2) '【ここが変更】 Cells(3, i + 17).Copy Cells(i * 12 + 1, "B") '【ここが変更】 SV = Cells(i * 12 + 1, "B").Value For Each myRang In myArea.Areas For Each c In myRang If Val(c.Value) = SV Then For Each cc In Intersect(c.Offset(-1, -1).Resize(3, 3), myRang) If Abs(Val(c.Value) - Val(cc.Value)) <= 1 _ And c.Address <> cc.Address Then cc.Interior.Color = vbRed flg = True End If Next cc If flg = True Then c.Interior.Color = vbRed Else c.Interior.Color = vbYellow End If End If flg = False Next c Next myRang Next i '作業行削除 Rows("1:1").Delete '作業列削除 Columns("A:A").Delete ActiveCell.Activate Application.ScreenUpdating = True End Sub
その他の回答 (1)
- watabe007
- ベストアンサー率62% (476/760)
こんばんは 複写数はM1セル、検索値セルはM2セルより右へ としています。 Sub Test() Dim i As Long, myArea As Range Dim myRang As Range, c As Range Dim SV As Long, cc As Range, flg As Boolean Application.ScreenUpdating = False '作業行挿入 Rows("1:1").Insert '作業列挿入 Columns("A:A").Insert Range("B13:L528").Clear For i = 1 To Range("N2").Value Range("B2:L12").Copy Cells(i * 12 + 2, "B") Set myArea = Cells(i * 12 + 2, "B").Resize(11, 11).SpecialCells(2) Cells(3, i + 13).Copy Cells(i * 12 + 1, "B") SV = Cells(i * 12 + 1, "B").Value For Each myRang In myArea.Areas For Each c In myRang If Val(c.Value) = SV Then For Each cc In Intersect(c.Offset(-1, -1).Resize(3, 3), myRang) If Abs(Val(c.Value) - Val(cc.Value)) <= 1 _ And c.Address <> cc.Address Then cc.Interior.Color = vbRed flg = True End If Next cc If flg = True Then c.Interior.Color = vbRed Else c.Interior.Color = vbYellow End If End If flg = False Next c Next myRang Next i '作業行削除 Rows("1:1").Delete '作業列削除 Columns("A:A").Delete Application.ScreenUpdating = True End Sub
お礼
いつも大変お世話になっています。 2つも回答いただきありがとうございます。