Dim インデックス As Integer '既存ブック・既存シートの矢印を全てコピー Workbooks(既存ブック名).Worksheets(既存シート名).Activate For インデックス = 1 To ActiveSheet.Shapes.Count ' MsgBox ActiveSheet.Shapes(インデックス).Name & " " & インデックス If InStr(ActiveSheet.Shapes(インデックス).Name, "Line") > 0 Then ActiveSheet.Shapes(インデックス).Select (False) End If Next Selection.Copy Range("A1").Select Workbooks(新規ブック名).Worksheets(新規シート名).Activate Range("R11").Select '貼り付け先の起点のセル ActiveSheet.Paste Range("A1").Select
Dim シェイプ As Shape Dim シェイプのレンジ As Range 'セルを指定して、Shapeオブジェクトを選択 ' http://www.relief.jp/itnote/archives/018407.php 'アクティブシートのすべての図形にループ処理 For Each シェイプ In 処理Book.Worksheets(1).Shapes '図形の配置されているセル範囲をオブジェクト変数にセット Set シェイプのレンジ = Range(シェイプ.TopLeftCell, シェイプ.BottomRightCell) '図形の配置されているセル範囲と '選択されているセル範囲が重なっていれば、文字列を取得 If Not Intersect(シェイプのレンジ, レンジ範囲.Cells(レンジ.Row + 1, レンジ.Column)) Is Nothing Then On Error Resume Next コメント = Trim(シェイプ.TextFrame.Characters.Text) End If Next
'アクティブシートのすべての図形にループ処理 For Each シェイプ In 処理Book.Worksheets(1).Shapes '図形の配置されているセル範囲をオブジェクト変数にセット Set シェイプのレンジ = Range(シェイプ.TopLeftCell, シェイプ.BottomRightCell) '図形の配置されているセル範囲と '選択されているセル範囲が重なっていれば、図形をコピー If Not Intersect(シェイプのレンジ, レンジ範囲.Cells(レンジ.Row + 1, レンジ.Column)) Is Nothing Then シェイプ.Copy End If Next '図形を集計シートに貼り付ける 集計シート.Range("H1").Cells(集計シート最終行, 1).PasteSpecial xlPasteAll 集計シート.Activate ''excel2010では以下のコードがないと縦と横が同じ比率で変更されます '図形.ShapeRange.LockAspectRatio = msoFalse '集計シート.Shapes(集計シート.Shapes.Count).ShapeRange.LockAspectRatio = msoFalse 'サイズ指定 '対象図形は、最後に貼り付けたので、図形の数で指定 With 集計シート .Shapes(集計シート.Shapes.Count).Height = 16# .Shapes(集計シート.Shapes.Count).Width = 30# End With
