Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


62504 / 76732 ←次へ | 前へ→

【18835】Re:これかな?
回答  Jaka  - 04/10/14(木) 9:55 -

引用なし
パスワード
   こんにちは。

おお〜、これこれ、と思いましたが、ちょっと違うような...。
これだと図形類が、セル範囲にすっぽり入ってないとダメですね。
ちょっとでもひっかっていたらってやつがあったと思うんですけど...。
確かりんさんはそんな風に言っていたような気がします。
試してみなかったんで、その辺はあいまいですが。

これでよかったら、こんな感じに配列にセットすれば良いです.

Sub 範囲選択()
 
Dim Sh As Shape, r1 As Range, r2 As Range
Dim ObjTb() As Variant, Ct As Integer
  'On Error GoTo errout

  If ActiveSheet.ProtectContents Then
  Else
   If TypeName(Selection) = "Range" Then
    'Selection.Clear
    If TypeName(Selection) = "Range" Then
     If ActiveSheet.Shapes.Count > 0 Then
      For Each Sh In ActiveSheet.Shapes
       '図形が完全に範囲に含まれる場合は削除する
       '図形左上セルのチェック
       Set r1 = Application.Intersect(Selection, _
                      Sh.TopLeftCell)
       '図形右下セルのチェック
       Set r2 = Application.Intersect(Selection, _
                      Sh.BottomRightCell)
       If r1 Is Nothing Or r2 Is Nothing Then
       '左上セルまたは右下セルが選択範囲の外にある場合は無視
        '両方外にある場合も無視
       Else
        Ct = Ct + 1
        ReDim Preserve ObjTb(1 To Ct)
        ObjTb(Ct) = Sh.Name
       End If
      Next
     End If
    End If
   Else
    'Selection.Delete
   End If
  End If
  On Error Resume Next
  If UBound(ObjTb) <> 0 Then
    ActiveSheet.Shapes.Range(ObjTb).Select
  End If
  Set r1 = Nothing: Set r2 = Nothing
  Erase ObjTb
  Exit Sub
errout:

End Sub

0 hits

【18820】図形の選択 ちょこちょこ 04/10/13(水) 15:48 質問
【18823】Re:図形の選択 Jaka 04/10/13(水) 16:27 発言
【18825】これかな? ぴかる 04/10/13(水) 17:19 発言
【18827】Re:これかな? ちょこちょこ 04/10/13(水) 18:54 お礼
【18835】Re:これかな? Jaka 04/10/14(木) 9:55 回答

62504 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free