エクセル マクロ 線対称・点対称の位置に色づけする

質問

いつもお世話になっております。
エクセルのマクロを使って（あるいは数式でもいいのですが・・・）やりたいことが２つあります。

(1)指定したセルを「対称の中心」として，アクティブセルと点対称の位置にあるセルに色付けができないかと思っています。

(2)指定した列を「対称の軸」として，アクティブセルと線対称の位置にあるセルに色付けできないかと思っています。

もし可能であるようなら，どなたかマクロを教えていただけませんか？
いつも他力本願で申し訳ないのですが，教育に役立てたいと思っています。どうかご教授ください。

回答No.3

keithin · ベストアンサー

sub macro1()
’Ｊ１０セルに対して点対象位置
　dim org as range
　set org = range("J10")

　on error resume next
　org.offset(org.row - activecell.row, org.column - activecell.column).interior.colorindex = 4
end sub

sub macro2()
’Ｊ列に対して線対象位置
　dim org as range
　set org = cells(activecell.row, "J")

　on error resume next
　org.offset(org.row - activecell.row, org.column - activecell.column).interior.colorindex = 6
end sub
＃同じマクロを流用していますが，勿論行オフセットをゼロに固定して構いません

お礼

ご教授ありがとうございました。
私のやりたいことに一番近かったコードでした。
また何かありましたらよろしくお願いいたします。

回答No.4

NotFound404

遅ればせながら・・・。
下記コードをシートモジュールにコピペッタン。

使い方
A2セルに基準となるアドレスを入れます。
半角で、L10 とか m15 など。
A3セルには、半角小文字で、p h v のいずれか。
p→点
h→水平
v→垂直
A1セルに、半角で0以外を入力。
青（選択セル）に合わせて 赤セルが移動します。
エラー処理は手抜きなので、動かなくなったらエクセルを再起動のこと。
もしかしたらバージョン違いで動かないかも？当方Excel2010。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
　　Dim rBase As Range　'基準点（線）
　　Dim hB As Integer, vB As Integer
　　Dim cC '点、縦、横の選択

　　If Range("A1") = 0 Then Exit Sub

　　Set rBase = Range(Range("A2").Value)
　　If Err.Number <> 0 Then Exit Sub

　　cC = Range("A3").Value

　　Application.EnableEvents = False
　　Application.ScreenUpdating = False

　　'シート内の色をクリア
　　Cells.Select
　　With Selection.Interior
　　　　.Pattern = xlNone
　　　　.TintAndShade = 0
　　　　.PatternTintAndShade = 0
　　End With

　　'基準点（線）設定
　　Select Case cC
　　　　Case "p"
　　　　　　rBase.Interior.Color = vbBlack
　　　　Case "h"
　　　　　　Rows(rBase.Row).Select
　　　　　　With Selection.Interior
　　　　　　　　.Pattern = xlSolid
　　　　　　　　.PatternColorIndex = xlAutomatic
　　　　　　　　.ThemeColor = xlThemeColorDark1
　　　　　　　　.TintAndShade = -0.349986266670736
　　　　　　　　.PatternTintAndShade = 0
　　　　　　End With
　　　　Case "v"
　　　　　　Columns(rBase.Column).Select
　　　　　　With Selection.Interior
　　　　　　　　.PatternColorIndex = xlAutomatic
　　　　　　　　.ThemeColor = xlThemeColorDark1
　　　　　　　　.TintAndShade = -0.349986266670736
　　　　　　　　.PatternTintAndShade = 0
　　　　　　End With
　　End Select

　　Target.Select
　　Target.Interior.Color = vbBlue
　　hB = rBase.Row - Target.Row
　　vB = rBase.Column - Target.Column

　　Select Case cC
　　　　Case "p"
　　　　　　rBase.Offset(hB, vB).Cells.Interior.Color = vbRed
　　　　Case "h"
　　　　　　Cells(rBase.Offset(hB, 0).Row, Target.Column).Cells.Interior.Color = vbRed
　　　　Case "v"
　　　　　　Cells(Target.Row, rBase.Offset(0, vB).Column).Cells.Interior.Color = vbRed
　　End Select

　　Application.ScreenUpdating = True
　　Application.EnableEvents = True
End Sub

お礼

ご教授ありがとうございました。
エラー無く実行できました。
基準値をセル入力できるので，応用が利きそうです。
また何かありましたらよろしくお願いいたします。

回答No.2

tom04

こんばんは！
面白そうなのでトライしてみました。

Sheetモジュールです。

Dim myRow As Long, myCol As Long, c As Range, r As Range 'この行から
Dim myX As Long, myY As Long
Sub SAmple1()
If Selection.Count > 1 Then
MsgBox "1セルのみ選択"
Exit Sub
End If
With ActiveSheet
.Cells.ClearContents
.Cells.Interior.ColorIndex = xlNone
End With
With Selection
.Value = "○"
.Font.ColorIndex = 6
.Interior.ColorIndex = 6
End With
MsgBox "点対象の場合はひとつのセルを" & vbCrLf & "線対象の場合は複数セルを選択"
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set c = ActiveSheet.Cells.Find(what:="○", LookIn:=xlValues, lookat:=xlWhole)
Set r = ActiveSheet.Cells.Find(what:="×", LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing And Not r Is Nothing Then Exit Sub
With Target
If .Count = 1 Then
.Value = "×"
.Font.ColorIndex = 1
.Interior.ColorIndex = 1
myRow = Abs(c.Row - .Row)
myCol = Abs(c.Column - .Column)
If c.Row > .Row Then
myX = myRow * -2
Else
myX = myRow * 2
End If
If c.Column > .Column Then
myY = myCol * -2
Else
myY = myCol * 2
End If
c.Offset(myX, myY).Interior.ColorIndex = 3
ElseIf Target(1).Row = Target(Target.Count).Row Then
.Value = "×"
.Font.ColorIndex = 1
.Interior.ColorIndex = 1
myRow = Abs(c.Row - .Row)
If c.Row > .Row Then
myX = myRow * -2
Else
myX = myRow * 2
End If
c.Offset(myX).Interior.ColorIndex = 3
ElseIf Target(1).Column = Target(Target.Count).Column Then
.Value = "×"
.Font.ColorIndex = 1
.Interior.ColorIndex = 1
myCol = Abs(c.Column - .Column)
If c.Column > .Column Then
myY = myCol * -2
Else
myY = myCol * 2
End If
c.Offset(, myY).Interior.ColorIndex = 3
Else
MsgBox "1行、または1列を選択してください"
Exit Sub
End If
End With
End Sub 'この行まで

※　まず最初のセル（起点のセル）を選択してマクロを実行してみてください。
※　対象セルがSheet外の場合はエラーとなります。m(_ _)m

お礼

ご教授ありがとうございました。
基準セル・基準列がその都度指定できるのが，応用が利きそうでおもしろかったです。このコードをアレンジしてみたいと思いました。
また何かありましたらよろしくお願いいたします。

回答No.1

satoron666

とりあえず、ヒントまで。

Sub Sample2()
Dim SelectRangeAddress As String
SelectRangeAddress = Selection.Address
Names.Add Name:="中心", RefersTo:="=" & SelectRangeAddress
End Sub

Sub Sample3()
Dim SelectRangeAddress As String
SelectRangeAddress = Selection.Address
Names.Add Name:="アクティブセル", RefersTo:="=" & SelectRangeAddress
End Sub

上記のものは、選択した位置に名前を定義するものです。

プログラムの流れとして、

１．セルを選択させるウィンドウを出す（対象の軸を選択してください。）　⇒きちんとした値が出るまで繰り返す
　　きちんとした値が入力されたら、色を塗る

２．セルを選択させるウィンドウを出す（対象の中心？を選択してください）⇒きちんとした値が出るまで繰り返す
　　きちんとした値が入力されたら、色を塗る

３．アクティブセルと軸？の対象位置を割り出す　（Offsetとか色々算出方法はある？）

うーん、こんな流れですかねぇ…

せめて、対称位置の割り出し方法は考えてもらえませんか？

お礼

ご教授ありがとうございました。
OFFSETで対称位置を割り出してみたいと思います。
また何かありましたらよろしくお願いいたします。