お酒好きのおしりトラブル対策とは

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

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

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

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

「エクセル マクロ 線対称・点対称の位置に」の質問画像

このQ&Aに関連する最新のQ&A

A 回答 (4件)

sub macro1()


’J10セルに対して点対象位置
 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()
’J列に対して線対象位置
 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
#同じマクロを流用していますが,勿論行オフセットをゼロに固定して構いません
    • good
    • 0
この回答へのお礼

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

お礼日時:2014/06/20 04:38

遅ればせながら・・・。


下記コードをシートモジュールにコピペッタン。

使い方
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
    • good
    • 0
この回答へのお礼

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

お礼日時:2014/06/20 04:38

こんばんは!


面白そうなのでトライしてみました。

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
    • good
    • 0
この回答へのお礼

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

お礼日時:2014/06/20 04:40

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



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

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

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

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

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

3.アクティブセルと軸?の対象位置を割り出す (Offsetとか色々算出方法はある?)


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


せめて、対称位置の割り出し方法は考えてもらえませんか?
    • good
    • 0
この回答へのお礼

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

お礼日時:2014/06/20 04:41

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

Qexcel 左右対照入れ替え

初めて質問させて頂きます。
excelで困っていることがあり質問させて頂きました。
excel シートに入力されている内容を左右対照入れ替えしたいのです。

簡単に書きますと、
A1 に 数字の1
B1 に 数字の2
C1 に 数字の3
D1 に 計算式 =A1+ B1 + C1

と入力してあるファイルがあったとして、それを

A1 に 計算式 =A1+ B1 + C1
B1 に 数字の3
C1 に 数字の2
D1 に 数字の1

と左右対称に入れ替えたいのです。
なんらかの方法は無いでしょうか?
宜しくお願い致します。

Aベストアンサー

#2です。試しに汎用化してみました。自分で使うシチュエイションは思い浮かびませんが...
Sub test()
Dim i As Long
Const mirrorColumnsNo As Long = 4

ActiveSheet.Columns(1).Resize(, mirrorColumnsNo).Cut Destination:=Sheets(2).Columns(1).Resize(, mirrorColumnsNo)
For i = 1 To mirrorColumnsNo
Sheets(2).Columns(i).Cut Destination:=ActiveSheet.Columns(mirrorColumnsNo - i + 1)
Next i
ActiveSheet.Columns(1).Resize(, mirrorColumnsNo).Replace What:=ActiveSheet.Name & "!", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
End Sub
最後は、Sheet1にある式に、Sheet1!という参照が付いてうるさいので、仕方なく取り除いています。

#2です。試しに汎用化してみました。自分で使うシチュエイションは思い浮かびませんが...
Sub test()
Dim i As Long
Const mirrorColumnsNo As Long = 4

ActiveSheet.Columns(1).Resize(, mirrorColumnsNo).Cut Destination:=Sheets(2).Columns(1).Resize(, mirrorColumnsNo)
For i = 1 To mirrorColumnsNo
Sheets(2).Columns(i).Cut Destination:=ActiveSheet.Columns(mirrorColumnsNo - i + 1)
Next i
ActiveSheet.Columns(1).Resize(, mirrorColumnsNo).Repl...続きを読む

Qエクセル 表の反転について

エクセルで作成した表を、鏡に移したような感じで反転させて使用したいのですが、どのような操作をすればよいのでしょうか?
反転させた後も編集を行いたいので、図として左右反転するという方法ではダメでした・・・
どうか、よろしくおねがいします。

Aベストアンサー

何で図として左右反転だとダメなのでしょうか?

セルの値を変えても図形は反映されます
1. A1:D5セル範囲をコピー
2. [Shift]押しつつ 編集 メニュー 図のリンク貼り付け
3. 図の左右反転
添付図参照

Qセル番号を返す関数

エクセルで、セル番号を返す関数はありますか??
セルの内容ではなくて、番号です。(A1、B3など)
調べてみましたがなかなか見つからなかったので、
わかる方教えてください。
宜しくお願い致します。

Aベストアンサー

文字として"C4"を返す。
=ADDRESS(ROW(C4),COLUMN(C4),4)

式を入力したセルの位置を文字列で返す。
=ADDRESS(ROW(),COLUMN(),4)

ADDRESSの3つ目の引数を変えると
$C$4
$C4
C$4
C4
の4つの形に出来ます。


人気Q&Aランキング

おすすめ情報