• ベストアンサー
※ ChatGPTを利用し、要約された質問です(原文:5×6マス検索→5×5マス検索への改造の仕方。)

5×6マス検索→5×5マス検索への改造の仕方

このQ&Aのポイント
  • 5×6マスを5×5マスに変更する方法について質問です。検索値と同じ値か、隣接数字との差が0か1なら塗潰す方法がある。
  • 具体的な5×5マスの配置が4つあり、それぞれの配置に対して同じ塗潰し方法を適用する。
  • 5×7マスでも同様の塗潰し方法が適用できるかもしれない。

質問者が選んだベストアンサー

  • ベストアンサー
  • watabe007
  • ベストアンサー率62% (476/760)
回答No.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

moguo4649
質問者

お礼

いつも大変お世話になっています。 2つも回答いただきありがとうございます。

その他の回答 (1)

  • watabe007
  • ベストアンサー率62% (476/760)
回答No.1

こんばんは 複写数は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

関連するQ&A

専門家に質問してみよう