Sample Macro  その他 [応用型] Previous Next

1) 選択された複数の図形の属性・前景色 このページのトップへ もくじへ 使用可能なExcelのバージョン
'=================================================================================
Sub 選択された複数の図形の中の各図形の属性を表示する()
    Worksheets("Sheet1").Activate               '※1
    With Selection
        個数 = .ShapeRange.Count
        For インデックス番号 = 1 To 個数
            名前 = .ShapeRange(インデックス番号).Name
            種類 = .ShapeRange(インデックス番号).Type
            ID = .ShapeRange(インデックス番号).ID '※2
            幅 = .ShapeRange(インデックス番号).Width
            高さ = .ShapeRange(インデックス番号).Height
            左上端セル = .ShapeRange(インデックス番号).TopLeftCell.Address
            左端距離 = .ShapeRange(インデックス番号).Left
            上端距離 = .ShapeRange(インデックス番号).Top
            MsgBox "選択された図形の内のインデックス番号 " _
                & インデックス番号 & " の図形の主な属性 " & vbCr & vbCr _
                & " 名前… " & 名前 & vbCr _
                & " 種類… " & 種類 & vbCr _
                & " ID… " & ID & vbCr _
                & " 幅  … " & 幅 & vbCr _
                & " 高さ … " & 高さ & vbCr _
                & " 左上端セル… " & 左上端セル & vbCr _
                & " 左端距離 … " & 左端距離 & vbCr _
                & " 上端距離 … " & 上端距離, , "すぐマク"
        Next
    End With
End Sub
'---------------------------------------------------------------------------------
Sub 選択された複数の図形の前景色を設定する()
    Worksheets("Sheet3").Activate               '※1
    With Selection
        個数 = .ShapeRange.Count
        For インデックス番号 = 1 To 個数
            With .ShapeRange(インデックス番号).Fill
                .ForeColor.RGB = RGB(255, 255, 0)
            End With
        Next
    End With
End Sub
'=================================================================================
<コメント>
※1 ""の中にはシート名を記述
※2 Macintoshでは実行できない
※3 複数の図形の中の選択された図形のサンプル
複数の図形の中の選択された図形のサンプル
サンプルブックのダウンロードは ここをクリック (YNxv262_Shapes.xls 80KB)
※ 一旦、ブックをハードディスクに保存し、開き直してから実行してください。


2) 選択されたテキストボックスのテキスト このページのトップへ もくじへ 使用可能なExcelのバージョン
'=================================================================================
Sub 選択されたテキストボックスのテキストを表示する()
    Worksheets("Sheet2").Activate
    MsgBox Selection.Characters.Text, , "すぐマク"
End Sub
'=================================================================================
<コメント>
※1 下図のように表示される
サンプル
サンプルブックのダウンロードは ここをクリック (YNxv262_Shapes.xls 80KB)
※ 一旦、ブックをハードディスクに保存し、開き直してから実行してください。


3) テキストボックスまたは矢印図形をコピー このページのトップへ もくじへ 使用可能なExcelのバージョン
'=================================================================================
Sub 指定セル範囲内のテキストボックスまたは矢印図形をコピー貼り付けする_Intersectで判定()
    Worksheets("Sheet1").Activate
    Set 指定セル範囲 = Range("A1:A10")           '調査するセル範囲
    For Each 各図形 In Worksheets("Sheet1").Shapes 'Sheet1の各図形について
        With 各図形
            Set 共有セル範囲 = Intersect(.TopLeftCell, 指定セル範囲)
            If Not 共有セル範囲 Is Nothing Then
                If .Type = msoTextBox Then       'テキストボックスか
                    .Copy
                    Worksheets("Sheet2").Activate
                    Range(.TopLeftCell.Address).Select
                    ActiveSheet.Paste
                ElseIf .Type = msoAutoShape Then 'オートシェイプか
                    If .AutoShapeType = msoShapeUpArrow Then '上矢印か
                        .Copy
                        Worksheets("Sheet2").Activate
                        Range(.TopLeftCell.Address).Select
                        ActiveSheet.Paste
                    ElseIf .AutoShapeType = msoShapeDownArrow Then '下矢印か
                        .Copy
                        Worksheets("Sheet2").Activate
                        Range(.TopLeftCell.Address).Select
                        ActiveSheet.Paste
                    ElseIf .AutoShapeType = msoShapeLeftArrow Then '左矢印か
                        .Copy
                        Worksheets("Sheet2").Activate
                        Range(.TopLeftCell.Address).Select
                        ActiveSheet.Paste
                    ElseIf .AutoShapeType = msoShapeRightArrow Then '右矢印か
                        .Copy
                        Worksheets("Sheet2").Activate
                        Range(.TopLeftCell.Address).Select
                        ActiveSheet.Paste
                    End If
                End If
            End If
        End With
    Next
End Sub
'=================================================================================
Sub セル範囲内のテキストボックスまたは矢印図形をコピー貼り付けする_座標で判定()
    Worksheets("Sheet1").Activate
    セル範囲 = "A1:A10"                         '調査するセル範囲
    With Range(セル範囲)
        セル範囲の上端 = .Top                   'セル範囲の座標を取得
        セル範囲の下端 = .Top + .Height
        セル範囲の左端 = .Left
        セル範囲の右端 = .Left + .Width
    End With
    For Each 各図形 In Worksheets("Sheet1").Shapes 'Sheet1の各図形について
        With 各図形
            If セル範囲の上端 <= .Top And _
               セル範囲の左端 <= .Left And _
               セル範囲の下端 >= .Top + .Height And _
               セル範囲の右端 >= .Left + .Width Then '範囲内にある図形なら
                If .Type = msoTextBox Then       'テキストボックスか
                    .Copy
                    Worksheets("Sheet2").Activate
                    Range(.TopLeftCell.Address).Select
                    ActiveSheet.Paste
                ElseIf .Type = msoAutoShape Then 'オートシェイプか
                    If .AutoShapeType = msoShapeUpArrow Then '上矢印か
                        .Copy
                        Worksheets("Sheet2").Activate
                        Range(.TopLeftCell.Address).Select
                        ActiveSheet.Paste
                    ElseIf .AutoShapeType = msoShapeDownArrow Then '下矢印か
                        .Copy
                        Worksheets("Sheet2").Activate
                        Range(.TopLeftCell.Address).Select
                        ActiveSheet.Paste
                    ElseIf .AutoShapeType = msoShapeLeftArrow Then '左矢印か
                        .Copy
                        Worksheets("Sheet2").Activate
                        Range(.TopLeftCell.Address).Select
                        ActiveSheet.Paste
                    ElseIf .AutoShapeType = msoShapeRightArrow Then '右矢印か
                        .Copy
                        Worksheets("Sheet2").Activate
                        Range(.TopLeftCell.Address).Select
                        ActiveSheet.Paste
                    End If
                End If
            End If
        End With
    Next
End Sub
'=================================================================================
サンプルブックのダウンロードは ここをクリック (YNxv262_AutoShapeType.xls 70KB)
※ 一旦、ブックをハードディスクに保存し、開き直してから実行してください。

Excel VBA Macro