[[20190226153501]]　『マクロによるオートシェイプ制御』（さら）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

　

『マクロによるオートシェイプ制御』（さら）

はじめまして。
よろしくお願いします。

C2〜C3、E2〜E3、G2〜G3
それぞれにIF関数の結果により、「なし」「甲」「乙」が入力されています。

D2〜D3、F2〜F3、H2〜H3
それぞれの上のセルが
「なし」何もしない+オートシェイプが存在したら削除する
「甲」ならD2、F2、H2にセルサイズでオートシェイプの〇
「乙」ならD3、F3、H3にセルサイズでオートシェイプの〇
としたいです。

どのようなマクロが可能でしょうか？
ボタンで制御したいと考えております。

＜ 使用 Excel：Excel2013、使用 OS：Windows7 ＞

はじめまして。
よろしくお願いします。

※2019.2.26 18:35修正させていただきました。

C2、C4、C6
それぞれにVLOOKUP関数の結果により、「なし」「甲」「乙」が入力されています。
C3〜D3、C5〜D5、C7〜D7
それぞれの上のセルが
「甲」ならD2、F2、H2にセルサイズでオートシェイプの〇
「乙」ならD3、F3、H3にセルサイズでオートシェイプの〇
「なし」何もしない+オートシェイプが存在したら削除する
としたいです。
どのようなマクロが可能でしょうか？
ボタンで制御したいと考えております。

イメージとしては下記になります。

C2　甲
C3 ○　D4　　

C4　甲
C5　○　D5　　

C6　乙
C7　　　D7　○

どなたかよろしくお願い致します
（さら） 2019/02/26(火) 18:39

オートシェイプでなく、〇を文字で表示、非表示ではだめなのでしょうか？

（マナ） 2019/02/26(火) 18:53

普通に〇とセルに出力されるだけなら関数で出来るということでしょうか？
〇を表示させたいセルにはデータがあるのでオートシェイプではないとダメなのです...
マクロ希望です(´･ω･`;)

あと記載ミスがありました...

C2　甲
C3 ○　D3　　
C4　甲
C5　○　D5　　
C6　乙
C7　　　D7　○
（さら） 2019/02/26(火) 20:02

実際のシートでも、この６セルだけなのでしょうか。

＞C3〜D3、C5〜D5、C7〜D7

（マナ） 2019/02/26(火) 20:11

いえ、増えることはあるかと思います(´･ω･`;)
（さら） 2019/02/26(火) 21:05
こんな感じでどうでしょうか。 
 事前準備（少ないなら手作業で）
 １）所定のセルに　○　を用意
 ２）○にセル番地を含む名前（丸C3,丸D3など）をつける


 ここからマクロ
 ３）C2、C4、C6を順番に調べ
 ４）「甲」なら、
　４-１）一つ下のセルの　○　のVisible=True
　４-２）一つ下で、一つ右のセルの　○　のVisible=false
 ５）「乙」なら
　５-１）一つ下のセルの　○　のVisible=false
　５-２）一つ下で、一つ右のセルの　○　のVisible=True
 ６）それ以外なら
　６-１）一つ下のセルの　○　のVisible=false
　６-２）一つ下で、一つ右のセルの　○　のVisible=false


 例えばC2が「乙」なら
C 3セルの　○　（丸C3)を非表示にするということです。
 activesheet.Shapes("丸C3").Visbe=False

（マナ） 2019/02/26(火) 21:35

マナ様
どの様に記述したら良いのかが全く分からないのですが...

まず前提条件の１と２は手作業でも大丈夫です。
個数は28個になるのですが、自動化とかできるのでしょうか？
もしくは過去ログであったのですが、オートシェイプを書くという方法も良いのかなと勝手に想像しています...

条件の方ですが、
If Range("C2").Value Like "*甲*" Then
という感じで順番に記載していくっていうことですか？

全くの素人なのですみませんがご教授いただければと思います
（さら） 2019/02/26(火) 22:28

＞If Range("C2").Value Like "*甲*" Then
は、
　If Range("C2").Value = "甲" Then
です。

（マナ） 2019/02/26(火) 22:39

Likeは不要なのですね！
これでThenとElse、End Ifというのを作りたい行の分だけ記載するのでしょうか？
それとも繰り返し処理的な記載で簡略化出来ますか？
変数でしたか？

あと、ThenとElseの時のセル番地の指定ですが、Rangeで記載していくしかありませんか？
もう1つCell.Offsetとかでしたか？これで繰り返し処理みたいなことは可能でしょうか？
（さら） 2019/02/26(火) 23:04

＞これでThenとElse、End Ifというのを作りたい行の分だけ記載

まずは自力でできる書き方↑で構いません。

＞繰り返し処理的な記載で簡略化

はそのあとで。

（マナ） 2019/02/26(火) 23:18

Sub ○付け() 
            Dim L, T, W, H As Variant
            Dim L2, T2, W2, H2 As Variant


            With Selection
             L = .Left
             T = .Top
             W = .Width
             H = .Height
            End With


            If W > H Then
              L2 = L + (W - H) / 2
              T2 = T
             Else
              L2 = L
              T2 = T + (H - W) / 2
            End If


            If W > H Then
              W2 = H
              H2 = H
             Else
              W2 = W
              H2 = W
            End If
    If Range("C2").Value = "甲" Then
        Range("C3").Select
            With ActiveSheet.Shapes.AddShape(msoShapeOval, L2, T2, W2, H2)
                .Fill.Visible = msoFalse
                .Line.ForeColor.RGB = RGB(0, 0, 0)
                .Line.Weight = 1
            End With
        Else
            If Range("C2").Value = "乙" Then
        Range("D4").Select
            With ActiveSheet.Shapes.AddShape(msoShapeOval, L2, T2, W2, H2)
                .Fill.Visible = msoFalse
                .Line.ForeColor.RGB = RGB(0, 0, 0)
                .Line.Weight = 1
            End With
       End If
       End If
End Sub

他の掲示板より引用したものを少し改造しただけですが、○の位置がまばらでうまくいきません。
ご教授ください。。。
（さら） 2019/02/27(水) 06:13

すいません、マナさんが指導しようとしている方向性をぶち壊してしまうかもしれませんが、考え方を変えるとシンプルになる別案です。

図形を表示/非表示したり削除するのではなく、全ての〇を削除後、改めて〇を全部描く、というロジックの方が、図形が既にあるかどうか等の処理が不要になります。

あと、注意点としては、〇の大きさや位置は、セルサイズが統一されていない場合におかしくなるSelectionなんてあてにならないものではなく、〇を置くセルの情報から得るべきだ、という事でしょうか。
（???） 2019/02/27(水) 11:20 

 Sub test()
    Dim i As Long
    Dim L As Single
    Dim T As Single
    Dim W As Single


    For i = ActiveSheet.Shapes.Count To 1 Step -1
        If ActiveSheet.Shapes(i).Name Like "test*" Then
            ActiveSheet.Shapes(i).Delete
        End If
    Next i


    For i = 2 To Cells(Rows.Count, "C").End(xlUp).Row Step 2
        If Cells(i, "C").Value <> "" Then
            With Cells(i, "C").Offset(1, IIf(Cells(i, "C").Value = "甲", 0, 1))
                If .Width < .Height Then
                    W = .Width
                    L = .Left
                    T = .Top + (.Height - W) / 2
                Else
                    W = .Height
                    L = .Left + (.Width - W) / 2
                    T = .Top
                End If
                With ActiveSheet.Shapes.AddShape(msoShapeOval, L, T, W, W)
                    .Name = "test" & Cells(i, "C").Address(0, 0)
                    .Fill.Visible = msoFalse
                    .Line.ForeColor.RGB = RGB(0, 0, 0)
                    .Line.Weight = 1
                End With
            End With
        End If
    Next i
 End Sub
（???） 2019/02/27(水) 11:25
???様
コメントありがとうございます。

図形を表示/非表示したり削除するのではなく、全ての〇を削除後、改めて〇を全部描く、というロジックの方が、図形が既にあるかどうか等の処理が不要になります。 全ての〇を消すしてから新たに書くがやりたかったです！
説明下手ですみませんm(_ _)m
現状では必要な箇所以外のセルには〇やオートシェイプはないのですが、今後出てきた場合に備えて範囲を指定して削除は可能でしょうか？

あと、注意点としては、〇の大きさや位置は、セルサイズが統一されていない場合におかしくなるSelectionなんてあてにならないものではなく、〇を置くセルの情報から得るべきだ、という事でしょうか。 運用の上で仮にセルサイズが変わるとと思いましてSelectionとしてみた(コピペですが)のですが、現状としてはサイズは固定でも大丈夫な状況です。
（さら） 2019/02/27(水) 12:30
コードを読んでもらえば判りますが、判定によって置いた〇には名前を付けているので、判定以外の図形は消しませんよ。 試しに何か図形を置いてから動かしてみると良いでしょう。

サイズについては、3行目と4行目の高さが違うのに、3行目の高さで4行目に〇を置く、なんてすると崩れます。 それに、マクロ実行前に何処を選択しているのかなんて不定ですし、複数の行や列を選択する事だってできる訳です。 セルではなく、画像を選択している場合もあります。 それらの場合でも、正しいサイズで〇を置くにはどうするか、を考えましょう。 貼り先セルを元にすると、行毎に高さが違っていても追従します。（縦横どっちが大きいかを判断していたので、行高さがバラバラな場合を考慮しているのだろうと推測しました）

逆に、全て同じ大きさの〇にしたいなら、例えばRange("A1")からだけサイズを得ておいて、行毎に変えるのは縦位置だけにすると良いです。
（???） 2019/02/27(水) 13:00

こんにちは。

　別シートでもいいので、○を表示させるセルを別に用意した方がいいと思います。
　
　で、図のリンク貼り付けで持ってくる。
（でれすけ） 2019/02/27(水) 13:32

早速試してみました！
いくつか改善したい点があります。
よろしくお願いします。

１．条件
現状→「甲」は正常に動きます。
　　　「甲」以外の空白ではない場合は全て○に統一されている
希望→「甲」はそのままで大丈夫です
　　　最初の投稿で書きました通り、「乙」ならD列に○、「なし」又は空白セルの場合は何もしないとしたい

２．範囲
希望→処理範囲を限定したい

マクロ有効範囲→【B22:E31】と【B69:E78】
条件入力セル→それぞれ【B22、B24、B26、B28、B30】【B69、B71、B73、B75、B77】

上記を踏まえて修正してみたものが下記です 

 Sub test()
    Dim i As Long
    Dim L As Single
    Dim T As Single
    Dim W As Single
    For i = ActiveSheet.Shapes.Count To 1 Step -1
        If ActiveSheet.Shapes(i).Name Like "test*" Then
            ActiveSheet.Shapes(i).Delete
        End If
    Next i
    For i = 22 To Cells(Rows.Count, "B").End(xlUp).Row Step 2
        If Cells(i, "B").Value <> "" Then
            With Cells(i, "B").Offset(1, IIf(Cells(i, "B").Value = "甲", 0, 2))
                If .Width < .Height Then
                    W = .Width
                    L = .Left
                    T = .Top + (.Height - W) / 2
                Else
                    W = .Height
                    L = .Left + (.Width - W) / 2
                    T = .Top
                End If
                With ActiveSheet.Shapes.AddShape(msoShapeOval, L, T, W, W)
                    .Name = "test" & Cells(i, "B").Address(0, 0)
                    .Fill.Visible = msoFalse
                    .Line.ForeColor.RGB = RGB(0, 0, 0)
                    .Line.Weight = 1
                End With
            End With
        End If
    Next i
 End Sub

この状態だと範囲の指定が出来ておりません。
範囲の指定をして、実行ボタンを作成して完了としたいです。
完成した場合、このシートをコピーしても全て正常に動くでしょうか？

また仮にの話ですが、○のサイズをセルサイズの90%で描きたい場合は、L、T、Wの式のどの場所に「 * 0.9」とすれば良いでしょうか？
なかなか適当に入れてみたのですが、位置がずれてしまいます...

よろしくお願いします！
（さら） 2019/02/27(水) 18:14

追記失礼します。

1.条件のところも改善出来てません。
よろしくお願いしますm(_ _)m
（さら） 2019/02/28(木) 01:07

「なし」「甲」「乙」という条件だったので、「なし」というのは空欄の事かと思ったのですが、"なし" と書かれているのですね。 しかも空欄もあるので、3択ではなく4択だった、と。 なら、"なし" の場合の条件を追加するだけですが、実は "無し" とかも…、とかでも良いようにしましょうか。

そして、C列を見て、C列またはD列に〇だったのが、B列をみて、B列またはD列に変えたようですが、これはそのまま活かします。 

 Sub test()
    Dim i As Long


    For i = ActiveSheet.Shapes.Count To 1 Step -1
        If ActiveSheet.Shapes(i).Name Like "test*" Then
            ActiveSheet.Shapes(i).Delete
        End If
    Next i
    For i = 22 To 31 Step 2
        Call testSub(i)
    Next i
    For i = 69 To 78 Step 2
        Call testSub(i)
    Next i
 End Sub


 Sub testSub(i As Long)
    Dim L As Single
    Dim T As Single
    Dim W As Single


    Select Case Cells(i, "B").Value
    Case "甲", "乙"
        With Cells(i, "B").Offset(1, IIf(Cells(i, "B").Value = "甲", 0, 2))
            If .Width < .Height Then
                W = .Width * 0.9
                L = .Left + .Width * 0.05
                T = .Top + (.Height - W) / 2
            Else
                W = .Height * 0.9
                L = .Left + (.Width - W) / 2
                T = .Top + .Height * 0.05
            End If
            With ActiveSheet.Shapes.AddShape(msoShapeOval, L, T, W, W)
                .Name = "test" & Cells(i, "B").Address(0, 0)
                .Fill.Visible = msoFalse
                .Line.ForeColor.RGB = RGB(0, 0, 0)
                .Line.Weight = 1
            End With
        End With
    End Select
 End Sub
（???） 2019/02/28(木) 09:56
???様
再度ありがとうございます！

無事に動作確認出来ました。
自分が修正した箇所と比較して勉強したいと思います。
また投稿することもあるかと思いますが、皆様よろしくお願い致しますm(*_ _)m
（さら） 2019/03/01(金) 08:28

コメント返信：

[ 一覧(最新更新順) ]

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.