親子におすすめの新型プラネタリウムとは?

I5:I24の範囲内のオートシェイプの数を数え、I25に合計数を表示させるマクロを作っているのですが、どうしても範囲指定の仕方が分かりません。教えてください。

'オートシェイプの合計数算出
Dim shp As Object
Dim cnt As Long
For Each shp In ActiveSheet.Shapes
If shp.Type = msoAutoShape Then
If shp.TopLeftCell.Column = 9 Then
cnt = cnt + 1
End If
End If
Next shp
Range("I25").Value = cnt
このマクロのどこにどう入れればよいでしょうか?

このQ&Aに関連する最新のQ&A

A 回答 (3件)

TopLeftCellプロパティとIntersect メソッドを使って


図形の左上端が範囲内にあるか判定します

Dim shp As Object
Dim cnt As Long

For Each shp In ActiveSheet.Shapes
  If shp.Type = msoAutoShape Then
    If Not Intersect(shp.TopLeftCell, Range("I5:I24")) Is Nothing Then
      cnt = cnt + 1
    End If
  End If
Next shp
Range("I25").Value = cnt

図形の右下も含めるのならBottomRightCellプロパティ
も条件に含めてください
    • good
    • 0
この回答へのお礼

お礼遅くなり申し訳ありません。
ありがとうございました。

お礼日時:2010/10/04 13:52

もともとオートシェイプなどの、シート上のオブジェクトは、シートに浮かんで要るようなもので、EXCELのシートのセルとは何の関係もないものです。

すなわちセルの属性ではない。
しかしそれでは不便な場合もあるので、
Sub test01()
MsgBox ActiveSheet.Shapes.Count
MsgBox ActiveSheet.Shapes(1).Name
MsgBox ActiveSheet.Shapes(1).TopLeftCell.Address
MsgBox ActiveSheet.Shapes(1).BottomRightCell.Address
MsgBox ActiveSheet.Shapes(1).BottomRightCell.Column
End Sub
をやるとわかるように、位置関係について、オブジェクト側から
TopLeftCell、BottomRightCellの属性を使えるようになっている。
ほかに「オートシェイプの書式設定」の「プロパティ」の「セルにあわせて・・」のような仕組みがあるだけである。
ーー
だから、質問の、「範囲指定の仕方と言っても、TopLeftCell等の番地が、質問者の考える範囲内にある(InterSectする)か聞くほかない。
これもオブジェクトの位置を動かすと変わる不安定なものである。
ーー
InterSectを使わないなら、ActiveSheet.Shapes(1).TopLeftCellなどのRowとColumnについて、列について2よりで大6より小、且つ行について3より大で8より小のような判別(IFで)プログラムでやることになる。
ーーー
TopLeftCellとBottomRightCell のどちらを問題にするのか、両方を考えるかの問題は、当然ある。
    • good
    • 0
この回答へのお礼

お礼遅くなり申し訳ありません。
ありがとうございました。

お礼日時:2010/10/04 13:51

>範囲内のオートシェイプの数



この表現はちょっとあやふやです。
範囲に完全に入っているものの数か
範囲に少しでも入っているものの数か
どちらでしょう。

で、2通り数えるコードを。。

'------------------------------------------
Sub Test()
 Dim Shp As Shape
 Dim Cnt1 As Long
 Dim Cnt2 As Long
 Dim myRange As Range

 Set myRange = Range("H1:J20") '●調査範囲、適宜に変更

For Each Shp In ActiveSheet.Shapes
 If Shp.Type = msoAutoShape Then

'●範囲内に完全に入っているSHAPE
 If Not Intersect(Shp.TopLeftCell, myRange) Is Nothing And _
  Not Intersect(Shp.BottomRightCell, myRange) Is Nothing Then
    Cnt1 = Cnt1 + 1
 End If

'●範囲内に一部でも入っているSHAPE
 If Not Intersect(Shp.TopLeftCell, myRange) Is Nothing Or _
  Not Intersect(Shp.BottomRightCell, myRange) Is Nothing Then
    Cnt2 = Cnt2 + 1
 End If

 End If
Next Shp

  Range("I25").Value = Cnt1
  Range("I26").Value = Cnt2
End Sub
'-----------------------------------------------

以上です。
 
    • good
    • 0
この回答へのお礼

お礼遅くなり申し訳ありません。
ありがとうございました。

お礼日時:2010/10/04 13:53

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

Qエクセルで○や×の図形の集計は出来ますか?

エクセルの集計について教えて下さい。
○や×といった図形の集計は出来るのでしょうか?
どなたか解る方よろしくお願いします。

Aベストアンサー

こんにちわ
○や×がテキストデータであれば集計できます。
 A列
 ◎
 ◎
 ○
 ○
 △
 ×
 ×
 ×
 ×
 ×

A列に○や×が複数あるとして、集計セルには
=COUNTIF(A1:A10,"○")
と入力すると、○の個数をカウントしてくれます。
いくつかの種類のデータをカウントして表示するには
=CONCATENATE("○の数は",COUNTIF(A1:A10,"○")," △の数は",COUNTIF(A1:A10,"△")," ◎の数は",COUNTIF(A1:A10,"◎")," ×の数は",COUNTIF(A1:A10,"×"),"です。")
と入力すると、結果は
「○の数は2 △の数は1 ◎の数は2 ×の数は5です。」
となります。
オートシェイプのカウントのことでしたら、これは勘違い回答です。
すみません。

QVBAマクロで、図形等のオブジェクトを選択(特定)する方法ってありますか

こんにちは。VBAマクロを少しかじっています。
顔写真付きの従業員の検索システムを作りました。名前を入力(選択)したら、データシートから職員コード、住所、電話番号などの情報を検索し検索画面に表示します。この際、別のシートに顔写真を貼り付けたもの(1セルに1枚。セルに従業員名を入力してある。)から、VLOOKUP関数を使ってセル照会することで、画像も同時に表示することができます。
別の職員に切り換えたり、クリアする場合の画像の処理は、削除用のシートを用意し、そこにセルごと移動し、終了時にシートごと削除する方法をとりました。(当然、確認用のダイアログボックスが表示されます。)
前置きが長くなりましたが、問題は、用済みの画像を選択するプロシージャがあれば、あえて削除用のシートを用意する必要はありません。セルの場合は、Rangeプロパティやcellsプロパティで特定できますが、画像などのオブジェクトをセル番地などを使って特定する方法ってあるのでしょうか。
因みに、画像の選択処理を、マクロ記録でプロシージャを作成したら、
ActiveSheet.Shapes("Picture 1").Select などとなります。
よろしくお願いします。

こんにちは。VBAマクロを少しかじっています。
顔写真付きの従業員の検索システムを作りました。名前を入力(選択)したら、データシートから職員コード、住所、電話番号などの情報を検索し検索画面に表示します。この際、別のシートに顔写真を貼り付けたもの(1セルに1枚。セルに従業員名を入力してある。)から、VLOOKUP関数を使ってセル照会することで、画像も同時に表示することができます。
別の職員に切り換えたり、クリアする場合の画像の処理は、削除用のシートを用意し、そこにセルごと移動し、終了時...続きを読む

Aベストアンサー

検索シートにシェイプが1つしかなければ
ActiveSheet.Shapes(1).Select
で選択
ActiveSheet.Shapes(1).Delete
で削除できます。

QVBAのロジックでEXCEL上にShape図形があるかないかをチェック

VBAのロジックでEXCEL上にShape図形があるかないかをチェックするには

EXCEL2007-VBAを勉強中です。
EXCELシート上にShape図形があるかないかをチェックするには
どのように書くのでしょうか

どうぞ宜しくお願いします。

Aベストアンサー

図形にはTopLeftCell と BottomRightCell プロパティがあります。
左上隅
MsgBox ActiveSheet.Shapes(1).TopLeftCell.Address
右下隅
MsgBox ActiveSheet.Shapes(1).BottomRightCell.Address


こんな感じでどうでしょうか。

Dim i As Integer

For i = 1 To ActiveSheet.Shapes.Count
If ActiveSheet.Shapes(i).TopLeftCell.Address = "$C$10" Then
MsgBox "セル$C$10に図形を発見しました"
End If
Next i

ちょっとレベルが上がりますが、下記でkeithinさんの回答が参考になります。
エクセルで指定セル範囲内の画像・オートシェイプ・値をマクロを使って削除
http://qa.mapion.co.jp/qa5824633.html


>情報が少なくすみませんでした。
>セル指定を行い、指定したセルにShape図形があるかないかを調べる方法を
少ないというよりも、間違い、レベルだと思いますです。
本文から、捕捉に書かれた、真の意図、を推測することは私には無理です。
アップする前に、意図が第3者に伝わるかどうか、文章を推敲されていますか?
(別に怒っているわけではありませんよ。)

図形にはTopLeftCell と BottomRightCell プロパティがあります。
左上隅
MsgBox ActiveSheet.Shapes(1).TopLeftCell.Address
右下隅
MsgBox ActiveSheet.Shapes(1).BottomRightCell.Address


こんな感じでどうでしょうか。

Dim i As Integer

For i = 1 To ActiveSheet.Shapes.Count
If ActiveSheet.Shapes(i).TopLeftCell.Address = "$C$10" Then
MsgBox "セル$C$10に図形を発見しました"
End If
Next i

ちょっとレベルが上がりますが、下記でkeithinさんの回答...続きを読む

QエクセルVBA 図形の選択法は?

セル範囲をコピー
図としてペースト
ペーストされた図形を選択

記録マクロで書くと下記のようになります。
Sub Macro1()
Range("G2:K15").Select
Selection.Copy
Range("A1").Select
ActiveSheet.Pictures.Paste.Select
ActiveSheet.Shapes.Range(Array("Picture 1")).Select
End Sub

・場所を指定してペーストするのは、事前にselectする必要あるのでしょうか?
・挿入された図の名前がPicture1と分ってないと選択出来ません。他に方法あるのでしょうか?
図は複数あり、たった今ペーストした図形を選択したいのです。

参考になるURLあるいは書籍はないでしょうか?

Aベストアンサー

>挿入された図の名前がPicture1と分ってないと選択出来ません。他に方法あるのでしょうか?

Pasteする際に、Excelが勝手につけた名前を変数に保存して、その名前でSelectすることができます。

名前の保存は、こんな感じで。
MyPicName = ActiveSheet.Pictures.Paste.Name  ’Pasteと同時に、その名前を変数に代入します。

QエクセルVBAでセル番地を指定してオブジェクト名取得

いつも大変おせわになり、ありがとうございます。
先日、エクセルシート内に貼り付けたオブジェクトの左上の角が位置するセル番地は、
ActiveSheet.Shapes("Check Box 1").TopLeftCell.Address
で求められることをご教示いただきましたが、逆に、セル番地を指定して、そこにオブジェクトの左上の角があるオブジェクト名を取得する方法はありますでしょうか?
ご教示いただければ幸いです。

Aベストアンサー

参考程度ということで・・(^^;


 
Sub TEST()

 Dim myCell As Range
 Dim myShape As Shape

 Set myCell = Range("F5")

 For Each myShape In ActiveSheet.Shapes
   If myCell.Address = myShape.TopLeftCell.Address Then
      MsgBox myShape.Name
      Exit For
   End If
 Next myShape

End Sub
 
 

QEXCEL VBA で現在開いているブックのファイル名を取得する方法

EXCEL2003 VBAで業務を簡素化するために、現在開いているブックのファイル名を取得する方法が分かりません。
作業手順をマクロを使って処理していますが、オリジナルのワークブックをファイル名を変えて保存し、以後、このワークブックを読み込んで使用しています。
このときのVBAは、オリジナルのファイル名を使っているため、ファイル名を変更するとエラーになり、以後の業務に使用できません。
常にファイル名を取得出来るVBAをどなたか、教えて下さい。

Aベストアンサー

>現在開いているブックのファイル名
 ちょっと曖昧な表現かなぁという気もいたしますが、VBAが書いてあるブックのブック名は
ThisWorkbook.Name
で、現在 "アクティブにして" 操作対象になっているブックの名前は
ActiveWorkbook.Name
ですね。

 しかし、
>VBAは、オリジナルのファイル名を使っているため、ファイル名を変更するとエラーになり
というような文脈からすると、
ThisWorkbook.Name
の方ですかね。

QエクセルVBAで画像を貼り付ける座標設定方法は?

Sheets("Sheet1")に貼り付けたJ-pegの画像(=シンボルマーク)を別なシートに貼り付けるのは下記のVBAで出来ました。ただ、これでは貼り付け先のシートのセルK12が、貼り付け元のK12と同じ位置でないと思った場所に張り付きません。
そこでセルで場所を指定するのではなく、座標のようなもので指定する方法はないものかと考えた次第です。
オートシェイプなどは座標指定で作成できるのですが、J-pegのような画像はどうすればいいのでしょうか?

Sub TEST()
Sheets("FACE").Shapes("シンボルマーク").Copy
ActiveSheet.Range("K12").Select
ActiveSheet.Paste
End Sub

Aベストアンサー

#1です。
>この場合、ファイルをエクセルにくっつけて渡すなんてこと
>はできないものでしょうか?(別々にではなくあくまでエク
>セルのブックに付属した形で)
Excelのブックに付属した形にするなら、コピーペーストする方がいいと思います。一旦挿入した画像を別途保存するのは、簡単には出来ないと思います。

複数のシートで同じような作業をするなら、次のような方法も考えられます。
Function CpyMrk(MrkNM As String, myTop As Single, myLeft As Single)
Sheets("FACE").Shapes(MrkNM).Copy
ActiveSheet.Paste
ActiveSheet.Shapes(MrkNM).Top = myTop
ActiveSheet.Shapes(MrkNM).Left = myLeft
End Function

Sub test()
CpyMrk "シンボルマーク", 10, 10
End Sub

Qオブジェクトをカウントする

エクセルで、オブジェクトのカウントをすることはできるのでしょうか。


例えば、A4とC4にオブジェクトを配置する。

E4にそのオブジェクトをカウントした数(2)を表示させると言うことです。

可能でしょうか?

Aベストアンサー

> エクセルにデフォルトで存在する星型のオブジェクト

使用している色をいちいち数値や色名で指定すると煩雑ですので、
数えたい色(例えば赤)の星型をひとつ選択した状態で実行します。
エラー処理はしてませんので、オブジェクトを選択しないで実行すると
エラーになります。

Sub Test1()
 Dim shp, Col, C
 Col = Selection.ShapeRange.Fill.ForeColor.SchemeColor '(A)
 For Each shp In ActiveSheet.Shapes
  If shp.AutoShapeType = msoShape5pointStar Then    '(B)
   If shp.Fill.ForeColor.SchemeColor = Col Then C = C + 1 '(C)
  End If
 Next
 Range("E4").Value = C
End Sub

(A):選択している星型の色を取得しています。
(B):種類がオートシェイプの星形かどうかを判断しています。
(C):星型の色が最初に選択していたものと同じ色ならカウントします。

> エクセルにデフォルトで存在する星型のオブジェクト

使用している色をいちいち数値や色名で指定すると煩雑ですので、
数えたい色(例えば赤)の星型をひとつ選択した状態で実行します。
エラー処理はしてませんので、オブジェクトを選択しないで実行すると
エラーになります。

Sub Test1()
 Dim shp, Col, C
 Col = Selection.ShapeRange.Fill.ForeColor.SchemeColor '(A)
 For Each shp In ActiveSheet.Shapes
  If shp.AutoShapeType = msoShape5pointStar Then    '(B)
   If shp...続きを読む

QExcelのマクロを使用してオートシェイプ図形の色を変えたいのです。

Excelのマクロを使用してオートシェイプ図形の色を変えたいのです。

オートシェイプ図形を50個ならべて、マウスでクリックしてものは色が変わるようにしたいと思います。
マクロ記録をすると以下のようになりました。
Sub Macro1()
ActiveSheet.Shapes("AutoShape 1").Select
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 45
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid
End Sub

このプログラムを50個書くわけにはいかないのですが、プログラムで処理するのに問題点が2つ出てきました。

・オートシェイプ図形の名前が"AutoShape 1"となっていますが、これを変更したいのですが、書式設定にはありませんでした。変更するにはどうすればよいのでしょう?

・クリックしたオートシェイプ図形がどれであるかを返す関数がないと、どの図形がクリックされたかわからないのですが、これを返す関数はあるのでしょうか?

よろしくお願いします。

Excelのマクロを使用してオートシェイプ図形の色を変えたいのです。

オートシェイプ図形を50個ならべて、マウスでクリックしてものは色が変わるようにしたいと思います。
マクロ記録をすると以下のようになりました。
Sub Macro1()
ActiveSheet.Shapes("AutoShape 1").Select
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 45
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid
End Sub

このプログラムを50個書くわけにはいかないのですが、プログラムで...続きを読む

Aベストアンサー

質問者さんが何をなさりたいのかによって、答えが全く変わってきますが (^_^)

50ある図形の一部について色を変えたい、その手間を省きたい
ということなら F4 キーで繰り返し処理ができます。


手間がかかってもよいから、ご質問の通り動くプログラムを作りたい
ということなら、

> オートシェイプ図形の名前が"AutoShape 1"となっていますが、これを変更したい
  Worksheets("シート名").Shapes("シェイプ名").Name = "あなたの好きな名前"

で変えられます。

ちなみにエクセルが自動でつけてくれた名前を知るには

Sub List()
Dim シェイプ As Shape
  For Each シェイプ In Worksheets("Sheet1").Shapes
    Debug.Print シェイプ.TopLeftCell.Address; " "; シェイプ.Name
  Next
End Sub

などとすればよろしいかと思います。こうすればセル位置で確認できます。
なおここで表示される名前は右端に半角空白を一つあけて連番がついているようです。


> ・クリックしたオートシェイプ図形がどれであるかを返す関数
ありません。但し、その関数を自分で作ることはできます。
例えばこんな感じです

Sub Shapeの色を変える()
  With Worksheets("Sheet1").Shapes(Application.Caller)
    .Fill.ForeColor.RGB = RGB(255, 0, 0)
    .Line.ForeColor.RGB = RGB(0, 255, 0)
  End With
End Sub

で、その自作関数を図形にリンクしてやる方法は
  図形を右クリックして 『マクロの登録』 で登録するか
  シェイプ.OnAction プロパティにそのマクロ名を文字列でセットしてやる
試してみましたが、この自作関数はモジュール上に書く必要があるようです。
それと、もちろんですが、50の図形全部についてマクロの登録がひつようです。
マクロを使って登録してもよろしい。
但し、シートにコマンドボタンがあるときは除外しないとエラーになります。

Sub btnShape_Click()
  Dim Shp0 As Shape
  For Each Shp0 In Worksheets("Sheet1").Shapes
    Shp0.OnAction = "Shapeの色を変える"
  Next
End Sub

質問者さんが何をなさりたいのかによって、答えが全く変わってきますが (^_^)

50ある図形の一部について色を変えたい、その手間を省きたい
ということなら F4 キーで繰り返し処理ができます。


手間がかかってもよいから、ご質問の通り動くプログラムを作りたい
ということなら、

> オートシェイプ図形の名前が"AutoShape 1"となっていますが、これを変更したい
  Worksheets("シート名").Shapes("シェイプ名").Name = "あなたの好きな名前"

で変えられます。

ちなみにエクセルが自動でつけてく...続きを読む

QExel VBA 別ブックから該当データを検索し、必要なデータを取得する方法について

部品表というブックがあります
A列に商品名、B列に商品番号が入力してあります。C列のコードは未入力です。
A列     B列     C列      
商品名  商品番号  コード
モータ  U-1325-L  
ホルダ  R-134256

また、コード一覧表という別のブックには、A列に商品番号と、B列にコードが、何千件も入力されています。

やりたいことは
部品表のC列のコード欄に、コード一覧表ブックから商品番号と一致するコードを貼り付けしたいのです。

部品表は、何百種類もありますので、関数ではなく、マクロで処理を希望します。

自分では、部品表の商品番号をコピーして、コード一覧表で検索し、検索結果の右隣のセル(B列のコード)の値を部品表のC列に貼り付ければよいかと思い、書いてみたんですが…

Sub 別ブックから貼り付ける()
  Dim 検索する As Long
Windows("部品表.xls").Activate
検索する = cells(i,2).Value
Windows("コード一覧表.xls").Activate
ActiveWindow.SmallScroll Down:=-3
Selection.AutoFilter Field:=3, Criteria1:="=検索する", Operator:= xlAnd

と、してみたものの、検索しても、その検索結果の隣のセルのコードをどうやって取得すればいいのかが、わかりませんでした。

基本事項は本で学びましたが、呪文のようなコードはよく理解できません。懸命にネットで検索して、訳して理解する努力をしてはいますが。

どうぞよろしくお願いします。

部品表というブックがあります
A列に商品名、B列に商品番号が入力してあります。C列のコードは未入力です。
A列     B列     C列      
商品名  商品番号  コード
モータ  U-1325-L  
ホルダ  R-134256

また、コード一覧表という別のブックには、A列に商品番号と、B列にコードが、何千件も入力されています。

やりたいことは
部品表のC列のコード欄に、コード一覧表ブックから商品番号と一致するコードを貼り付けしたいのです。

部品表は、何百種類もありますので、関数...続きを読む

Aベストアンサー

こんにちは。
とりあえず実用性も踏まえました。
メインの動作はワークシート関数のVLOOKUPをVBA上で使用していますので理解はしやすいかと思います。
また、質問文から察するに「部品表.xls」と「コード一覧表.xls」の両方を開いて処理されていますが「コード一覧表.xls」はプログラム内で開いて閉じているので実行するときは「コード一覧表.xls」は閉じて置いてください。
Option Explicit
Sub Sample()
 Application.ScreenUpdating = False
 Dim I As Long
 Dim xlBook
 Set xlBook = Workbooks.Open("C:\★★\コード一覧表.xls") '★要変更★
 I = 2
 Do While Range("A" & I).Value <> ""
  ThisWorkbook.Worksheets("Sheet1").Range("C" & I).Value = Application.VLookup(ThisWorkbook.Worksheets("Sheet1").Range("B" & I).Value, xlBook.Worksheets("Sheet1").Range("A2:B65535"), 2, 0)
  I = I + 1
 Loop
 xlBook.Close
 Application.ScreenUpdating = True
 MsgBox ("完了")
End Sub

こんにちは。
とりあえず実用性も踏まえました。
メインの動作はワークシート関数のVLOOKUPをVBA上で使用していますので理解はしやすいかと思います。
また、質問文から察するに「部品表.xls」と「コード一覧表.xls」の両方を開いて処理されていますが「コード一覧表.xls」はプログラム内で開いて閉じているので実行するときは「コード一覧表.xls」は閉じて置いてください。
Option Explicit
Sub Sample()
 Application.ScreenUpdating = False
 Dim I As Long
 Dim xlBook
 Set xlBook = Workbooks....続きを読む


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング