Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7 Professional : Excel 2013)
セルにシェイプがあるか?ないか?
投稿日時: 17/10/12 08:46:03
投稿者: montaU

お世話になります、よろしくお願いします。
単一セルにシェイプが、あるか?ないか?を確認するにはどうすればよろしいでしょうか?。
 
単一セルと同サイズの長方形シェイプがあり、例えばA1からA10までを範囲として、A3、A6、A9に3つのシェイプがあった場合に、それらをA1、A2、A3セルに並べ替えたいのです。
最終的には、2列20行を1ブロックとして、4ブロックある範囲をチェックできるように仕上げたいと思ってますが、とりあえずは1列10行でできるようにならないと。
 
指定したセルへの移動は、指定したセルのtop、leftを取得し、シェイプのtop、leftへ与えることで可能なことは確認しています。

回答
投稿日時: 17/10/12 09:47:55
投稿者: 隠居じーさん

引用:
単一セルにシェイプが、あるか?ないか?を確認するにはどうすればよろしいでしょうか?。

ActiveSheet.Shapes.Countの値が0なら有りません。
コレクションに含まれるオブジェクトの数を表す長整数型 (Long) の値を返します
ActiveSheet.Shapes(1).TopLeftCell.Address
ActiveSheet.Shapes(1).BottomRightCell.Address
何かが使えますので
あとは回すなり、個別指定なりで
お望みのシェープをお望みのセルへ
でいけるのでは
試してません m( )m
 

回答
投稿日時: 17/10/12 13:28:28
投稿者: 隠居じーさん

引用:

A3、A6、A9に3つのシェイプがあった場合に、それらをA1、A2、A3セルに並べ替えたいのです。

montaUさん
Worksheets(1)が対象シートである前程ですが
参考まで
Sub main()
  Worksheets(1).Activate
  Dim cnt As Integer
  cnt = ActiveSheet.Shapes.Count
  Set ws = ActiveSheet
  If cnt <> 0 Then
    Dim tmp As Shape
    Dim i As Long: i = 0
    For Each tmp In ws.Shapes
      tmp.top = Cells(i + 1, 1).top
      tmp.Left = Cells(i + 1, 1).Left
      i = i + 1
    Next
  End If
  Set ws = Nothing
End Sub

投稿日時: 17/10/12 13:34:26
投稿者: montaU

隠居じーさん様
 
連投申し訳ありません、ありがとうございます。
とりあえずお礼まで。
 
検証結果は、しばらく猶予ください、よろしくお願いします。

回答
投稿日時: 17/10/12 13:55:24
投稿者: ピンク

こんな感じかな
Dim myShp As Shape, i As Long
For Each myShp In ActiveSheet.Shapes
    If Not Intersect(myShp.TopLeftCell, Range("A1:A10")) Is Nothing Then
            i = i + 1
            myShp.Top = Cells(i, "A").Top + (myShp.Top - myShp.TopLeftCell.Top)
        End If
    Next
End Sub

回答
投稿日時: 17/10/12 13:59:10
投稿者: WinArrow
投稿者のウェブサイトに移動

>例えばA1からA10までを範囲として、A3、A6、A9に3つのシェイプがあった場合に、
>それらをA1、A2、A3セルに並べ替えたいのです。
 
セル側から直接的にShapeを判断することは、難しいです。
 
結局は全図形を参照して
隠居じーさん さんのレスにあるように
>ActiveSheet.Shapes(xx).TopLeftCell.Address
で乗っているセルを判断します。
 
気を付けなくていけないことは、
手作業でセルに収めた場合に、図形の左上端がちょっとでもずれていると、
意図するセルを取得することができなくなります。
今回の場合、A3セルに乗せたつもりでも、左上端がA2セルに掛っていた場合、
そのセルのTopLefcellアドレスはA2になってしまいます。
 
手操作になりますが、図形の書式設定の中の「配置」ボタンのメニューに
「枠線に合わせる」のチェックを入れて、4方向をセルにぴったり合わせることです。
 
または、図形を作成するときに、図形にセルを認識できるような名前を付けることです。
図形の名前を解析して、意図したセルに移動する方が確実です。
 
 
上記の前提が保証できると仮定しての参考コードです
Dim Shape As Shape
    With ActiveSheet
        If .Shapes(1).TopLeftCell.Address = "$A$3" Then
            .Shapes(1).Top = .Range("A1").Top
        End If
    End With
 
 
 
 

回答
投稿日時: 17/10/12 14:02:24
投稿者: WinArrow
投稿者のウェブサイトに移動

図形が単一せるに乗っているか?
 
という問題に対しては、
TopLeftcellとBottomRightCellの両方が同一セルを判断すればよいでしょう。

投稿日時: 17/10/12 14:09:25
投稿者: montaU

お世話になってます、ありがとうございます。
 
隠居じーさん様
 
当初の質問とは少しズレましたが、元の位置に戻すモジュールで使わせていただきました!、ありがとうございました!。
 
Sub all_reset()
Dim cnt As Integer
Dim tmp As Shape
    Set ws = ThisWorkbook.Worksheets("**")
    For Each tmp In ws.Shapes
        simei = tmp.Name
        If Len(simei) = 6 Then
            ret_Top = ws.Range(s_place(simei)(1)).Top
            ret_Left = ws.Range(s_place(simei)(1)).Left
            ws.Shapes(simei).Top = ret_Top
            ws.Shapes(simei).Left = ret_Left
        End If
    Next
    Set ws = Nothing
End Sub
※s_place(simei)(1)は別シートに元の位置セルをテーブルとしてあり、そこから取得しています。
 
ピンク様、WinArrow様
 
ありがとうございます。
また少し時間下さい、いろいろ試してみます。
いま自分で考えていることをコードにすると、おもいっきり冗長なコードになりそうな気がしたので、質問させていただきました。
シェープには識別用の名前は、つけてあります。

回答
投稿日時: 17/10/12 14:09:56
投稿者: ピンク

コードが一部、欠けていました。
Sub Test()
    Dim myShp As Shape, i As Long
    For Each myShp In ActiveSheet.Shapes
        If Not Intersect(myShp.TopLeftCell, Range("A1:A10")) Is Nothing Then
            i = i + 1
            myShp.Top = Cells(i, "A").Top + (myShp.Top - myShp.TopLeftCell.Top)
        End If
    Next
End Sub

投稿日時: 17/10/12 14:48:17
投稿者: montaU

隠居じーさん様、 ピンク様、WinArrow様
 
お世話になってます、ありがとうございます。
なかなか本質をつく質問も難しいです、いざ投稿する段になって、これでいいのか?とも思ったり。
 
>セル側から直接的にShapeを判断することは、難しいです。
 
結局、これだったのですね、私のレベルではどうにもしようがないような気がしてきました、1つのセルごとに総当たりで、あるかないかを判断させるしかないのか?と思った次第です。
 
今、少し思案していて (ピンク様の)Intersectをうまくアレンジできないかと考えています。また、少しトライしてみます、とりあえずはお礼まで、ありがとうございました。
 
結果書込み用に少し開けておきます、すいません。

投稿日時: 17/10/12 15:55:57
投稿者: montaU

これはいいです、ありがとうございました。
オールリセットと、このカラムリフレッシュ、後でもいいかと思っていたところが、先にできました!。
 
 
Sub colum_refresh()
    Dim myShp As Shape, i As Long, m As Long
    With Worksheets("**")
        For i = 2 To 9
            m = 4
            For Each myShp In .Shapes
                If Not Intersect(myShp.TopLeftCell, .Range(.Cells(5, i), .Cells(17, i))) Is Nothing Then
                    m = m + 1
                    myShp.Top = .Cells(m, i).Top
                End If
            Next
        Next
    End With
End Sub
 

回答
投稿日時: 17/10/12 16:23:18
投稿者: ピンク

>最終的には、2列20行を1ブロックとして、4ブロックある範囲をチェックできるよう
なら、こうだったのでは
Sub colum_refresh2()
     Dim myShp As Shape, i As Long, m As Long
     With Worksheets("Sheet2")
         For i = 2 To 9 Step 2
             m = 4
             For Each myShp In .Shapes
                 If Not Intersect(myShp.TopLeftCell, .Range(.Cells(5, i), .Cells(17, i + 1))) Is Nothing Then
                     m = m + 1
                     myShp.Top = .Cells(m, i).Top
                     myShp.Left = .Cells(m, i).Left
                 End If
             Next
         Next
     End With
End Sub

投稿日時: 17/10/12 16:27:40
投稿者: montaU

隠居じーさん様、 ピンク様、WinArrow様
 
なんとなくメドがついたような、この感激はすごいです。
当初の質問は、空いてるセルにシェイプを移動させたいという目的でした、
これを、先にリフレッシュして、その次の位置にセットするようにしたらいけるのでは?と思うようになりました、早速作り変えてみます。
 
ありがとうございました、つまづいたらまた質問させてください、よろしくお願いします。
 
※閉めようと思っていた矢先に!、ピンク様、感謝です、ありがとうございました。