[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『セル内容に応じて画像表示、変更』（よっしー）
初めて質問させていただきます。
建築資材の集計表を作っているのですが様々な形状があり、特に決まった名称がないため
オートシェイプで作った図形でそれぞれのパーツを区別しています。
たとえばＡ1セルに"1"〜"5"のリストを設定し、選んだ内容によってＢ1セルに表示する
画像を変更するという感じです。
いろいろ調べた結果、図形を名前定義してindirect関数で図のリンク貼り付けをする。
という方法を見つけたのですが、
この方法では同一シート内に10個ほどリンク貼り付けを行うとエクセルがフリーズしてしまいます。（私だけ？？）
集計表なので、最終的に100個ほど図形が並ぶ表を作りたいのです。
私はvbaに関しては全くの無知なのですがvbaによる貼り付けならば可能でしょうか？
そもそもあんまり図形が得意ではないエクセルでは同一シート上に100個も図形を並べること自体無理があるのでしょうか？
エクセル2007、windows vistaです。
よろしくお願いします！
図形を貼り付けるのは、コピペで出来ると思います。
＞Ａ1セルに"1"〜"5"のリストを設定し、選んだ内容によってＢ1セルに表示する画像を変更する こう言うことをしたければ、VBAに成るでしょう。
ただ、先に コピペで貼り付けた場合 ＞同一シート上に100個も図形を並べること自体無理がある かどうか、確認しておいて頂くのが良いと思います。
マクロは作ったけど、その制約で使えなかった なんて事になっても仕方がありませんので。
例えば、印刷するときにある決まった位置に 画像が表示されていればよい と言う事なら、常に100個並べておく必要は 無くなると思います。
(HANA)
>図形を名前定義してindirect関数で図のリンク貼り付けをする。という方法 http://www.officetanaka.net/excel/function/tips/tips14.htm
この方法ですか？
新規ブック（Sheet1、Sheet2 というシート名が存在する）にて、
標準モジュールに、
'==============================================================================
Option Explicit
Sub sample1()
Dim rw As Long
Dim nm As Name
Dim shp As Shape
Dim r As Range
For Each nm In ThisWorkbook.Names
nm.Delete
Next
With Worksheets("sheet2")
.DrawingObjects.Delete
.Cells.ClearContents
.Range(.Cells(1, 1), .Cells(10, 1)).Value = [{4;11;13;14;15;18;20;25;26;27}]
.Range(.Cells(11, 1), .Cells(20, 1)).Value = [{36;41;44;45;46;47;48;52;56;60}]
.Range(.Cells(21, 1), .Cells(30, 1)).Value = [{62;73;75;79;89;90;91;92;93;94}]
.Range(.Cells(31, 1), .Cells(40, 1)).Value = [{95;96;98;99;100;104;108;125;126;127}]
.Range(.Cells(41, 1), .Cells(50, 1)).Value = [{128;129;130;131;132;133;134;135;136;137}]
For rw = 1 To 50
Call mk_autoshape(.Cells(rw, 1), .Range("c" & (10 * rw - 9) & ":d" & (10 * rw - 1)))
.Range("c" & (10 * rw - 9) & ":d" & (10 * rw - 1)).Name = "shape" & rw
.Cells(rw, 6).Value = "shape" & rw
Next
End With
Worksheets("sheet1").Activate
With Worksheets("sheet1")
.DrawingObjects.Delete
With .Range("d10").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=indirect(""sheet2!$f$1:$f$50"")"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = True
End With
.Parent.Names.Add Name:="画像", RefersToR1C1:="=INDIRECT(Sheet1!R10C4)"
Set r = .Range("f8:g16")
With .OLEObjects.Add(ClassType:="Forms.CommandButton.1", Link:=False _
, DisplayAsIcon:=False, Left:=r.Left, Top:=r.Top, Width:=r.Width, Height:= _
r.Height)
.Select
End With
.Range("d10").Value = "shape1"
Application.ExecuteExcel4Macro "FORMULA(""=画像"")"
End With
End Sub
'==============================================================================
Function mk_autoshape(autotype As MsoAutoShapeType, rng As Range) As Shape
Dim sht As Worksheet
Set sht = rng.Parent
Set mk_autoshape = sht.Shapes.AddShape(autotype, rng.Left, rng.Top, rng.Width, rng.Height)
End Function
上記のsample1を実行してみてください。正常に（エラーも発生せずに)終了したら、 適当な名前で保存し、一度当該ブックを閉じて、再度開いてください。
Sheet1のセルＤ１０に入力規則のリストが設定されています（Shape1からShape50）。 何か選択してみてください。F8:G16辺りの図計が変化すれば、正常に作動しています。 コードで50個ほどのオートシェイプが切り替えられる設定を行っています。 これがうまくいくようなら、「エクセルがフリーズ」は、他の原因が考えられます。
私の環境（Excel2002、win2000)では、正常に作動しています。
試してみてください。
ichinose@昨日行ったラーメン屋、ものすごく咳きしながらラーメン作ってた・・、頭痛いのは気のせい？
ご提示頂いたコードを早速実行いたしましたところ、正常に動作することを確認いたしました。 しかし、大変申し訳ないのですが、一つのセルに対して100の図形をリンクさせるのではなく 一つのセルに対して20ほどリンクするセルを同一シート上に100ほど配置したいのです。 現在行っている方法はご察しの通り、 http://www.officetanaka.net/excel/function/tips/tips14.htm を参考に作成しております。
ご提示頂いたコードを参考に、リンクセルを増やしてみようと思います。すぐには無理かもしれませんが。。。 お手間を取らせましたことを深くお詫びするとともにお礼申し上げます。ありがとうございました。
>20ほどリンクするセルを同一シート上に100ほど配置したいのです。 ってことは、20*100=2000個の図形を同一ブックに配置するということですか？ 図形合計個数が100ぐらいなら・・・、と思っていましたが、2000もあるなら、 私なら、別の方法を考えますね！！
ichinose
一つ一つののセルに対しリンクする図形は全て同一のものです。したがって、 sheet2に配置された20の図形がsheet1にあるそれぞれのセルにリンクする。というかたちになります。 図形を表示するセルがＢ列に、1〜20のリストが設定されたセルがＡ列に配置されます。 Ａ1で「1」を選択するとＢ1に「1」に対応する図形が表示される。 Ａ2で「5」を選択するとＢ2に「5」に対応する図形が表示される。 Ａ3で再び「1」を選択するとＢ3にも「1」に対応する図形が表示される。 このような感じでリンクセルを増やしていったところ10ほど配置したところでエクセルがフリーズする 現象が発生したのです。ichinose様は相当エクセルに精通しておられるようですのでお伺いしたいのですが 私が未熟なりに考察するに、リンク貼り付けを増やしたことがフリーズを招く原因になったのではないかと 感じているのですが同じ処理をＶＢＡで行ってもやはり同じ結果になるのでしょうか？ もしくはＶＢＡならばリンクに頼らず直接貼り付けを行うことが可能なのでしょうか？
今、Sheet2に30個の図形（オートシェイプ）を作成し、Sheet1に100個のリスト（入力規則）と 100個のリンク貼り付け（カメラ機能）を作成しました。作成は、無事できました（約30分かかりました）。
とりあえず、動作も正常ですが、やはり動作が重く使い物にはなりそうもありません。
コードを提示しますから、確認してみてください。
'=================================================================================
'==============================================================================
Option Explicit
Sub sample1()
Dim nm As Name
Dim rw As Long
Dim g0 As Long
For Each nm In ThisWorkbook.Names
nm.Delete
Next
With Worksheets("sheet2")
.DrawingObjects.Delete
.Cells.ClearContents
.Range(.Cells(1, 1), .Cells(10, 1)).Value = [{4;11;13;14;15;18;20;25;26;27}]
.Range(.Cells(11, 1), .Cells(20, 1)).Value = [{36;41;44;45;46;47;48;52;56;60}]
.Range(.Cells(21, 1), .Cells(30, 1)).Value = [{62;73;75;79;89;90;91;92;93;94}]
For rw = 1 To 30
Call mk_autoshape(.Cells(rw, 1), .Range("c" & (10 * rw - 9) & ":d" & (10 * rw - 1)))
.Range("c" & (10 * rw - 9) & ":d" & (10 * rw - 1)).Name = "shape" & rw
.Cells(rw, 6).Value = "shape" & rw
Next
End With
Worksheets("sheet1").Activate
With Worksheets("sheet1")
.DrawingObjects.Delete
For g0 = 1 To 100
Call mk_list(.Range("a" & (10 * (g0 - 1) + 1)), _
"画像" & g0)
DoEvents
Next
For g0 = 1 To 100
Call mk_camera(.Range("c" & (10 * (g0 - 1) + 1) & ":d" & (10 * (g0 - 1) + 9)), _
"画像" & g0)
Next
End With
End Sub
'==============================================================================
Sub mk_list(ByVal rng As Range, ByVal nm As String)
With rng.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=indirect(""sheet2!$f$1:$f$30"")"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = True
End With
rng.Parent.Parent.Names.Add Name:=nm, RefersToR1C1:="=INDIRECT(" & rng.Address(, , xlR1C1, True) & ")"
rng.Value = "shape1"
End Sub
'==============================================================================
Sub mk_camera(rng As Range, nm As String)
With rng.Parent.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Link:=False _
, DisplayAsIcon:=False, Left:=rng.Left, Top:=rng.Top, Width:=rng.Width, Height:= _
rng.Height)
.Select
End With
Application.ExecuteExcel4Macro "FORMULA(""=" & nm & """)"
End Sub
'==============================================================================
Function mk_autoshape(autotype As MsoAutoShapeType, rng As Range) As Shape
Dim sht As Worksheet
Set sht = rng.Parent
Set mk_autoshape = sht.Shapes.AddShape(autotype, rng.Left, rng.Top, rng.Width, rng.Height)
End Function
sample1を実行してください。 正常に（エラーも発生せずに)終了したら、 適当な名前で保存し、一度当該ブックを閉じて、再度開いてください。
ちょっと他の方法（VBAでイメージコントロールを操作する方法）を試してみます。 提示した方法より、よさそうならまた投稿します。
ichinose
このような膨大な（私からみれば）データを30分で作り上げてしまわれたのですか！ どうやら私とはレベルというか次元が違うようです。。。 現在Excelが入ったＰＣが手元にないのでご提示頂いたコードをすぐに実行できないのが 悔しいのですが、明日私の方でも実行し動作状況を報告させていただきます。
さらに、また別のアプローチでの方法も試して頂けるとのことで、恐縮ですが よろしくお願い致します。
質問の最初に書き込んだ理由上、同一シート上に複数の図形を 配置することがよくあるのですが一度ブックを閉じて再度開くと 配置がずれるという現象がよく発生するのですが、他のExcel関係の サイトでも同じ事例が多数報告されているようです。 これについては仕様のようですね。。。（衝突しました。。よっしー）
>データを30分で作り上げてしまわれたのですか 念のために、誤解のないように・・・。 30分は、このプログラムの処理にかかる時間ですよ！
では、ActiveXControlのImageを使った方法です。結果としては、以下に記述する方法は、前回投稿の方法に比べて、快適な動作をします。
新規ブックにて試してください。
概要としては、表示したい図形は、すべてファイルとして（JpegでもGifでもbmp等）保存します。 これを「コントロールツールボックス」のイメージコントロールを使ってＶＢＡで表示切替を行います。 尚、入力規則のリストの代わりに「フォーム」のコンボボックスを使います。
標準モジュール(Module1）にオートシェイプをファイルとして保存するコード。
'==========================================================================
Option Explicit
Sub mk_shapefile()
Dim img As OLEObject
Dim shp As Shape
With Workbooks.Add
.Activate
Call mk_sample(.Worksheets(1))
DoEvents
Set img = mk_img(.Worksheets(1).Range("f1:g9"))
For Each shp In .Worksheets(1).Shapes
If shp.Type <> msoOLEControlObject Then
shp.Copy
DoEvents
img.Object.Picture = Clipboard_GetMetafile
Call SavePicture(img.Object.Picture, ThisWorkbook.Path & "\" & shp.Name & ".bmp")
End If
Next
.Close False
End With
End Sub
'==========================================================================
Sub mk_sample(sht As Worksheet)
Dim nm As Name
Dim rw As Long
For Each nm In sht.Parent.Names
nm.Delete
Next
With sht
.DrawingObjects.Delete
.Cells.ClearContents
.Range(.Cells(1, 1), .Cells(10, 1)).Value = [{4;11;13;14;15;18;20;25;26;27}]
.Range(.Cells(11, 1), .Cells(20, 1)).Value = [{36;41;44;45;46;47;48;52;56;60}]
.Range(.Cells(21, 1), .Cells(30, 1)).Value = [{62;73;75;79;89;90;91;92;93;94}]
For rw = 1 To 30
mk_autoshape(.Cells(rw, 1), .Range("c" & (10 * rw - 9) & ":d" & (10 * rw - 1))).Name = "shape" & rw
Next
End With
End Sub
'==============================================================================
Function mk_autoshape(autotype As MsoAutoShapeType, rng As Range) As Shape
Dim sht As Worksheet
Set sht = rng.Parent
Set mk_autoshape = sht.Shapes.AddShape(autotype, rng.Left, rng.Top, rng.Width, rng.Height)
End Function
別の標準モジュール（Module2）に図形をイメージコントロールにコピーするコード
'==========================================================================
Option Explicit
Private Const CF_ENHMETAFILE = 14
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Const vbPicTypeBitmap = 1
Private Const vbPicTypeIcon = 3
Private Const vbPicTypeEMetafile = 4
Private Type TPICTDESC
cbSizeofStruct As Long 'この構造体のサイズです。
picType As Long 'ピクチャーのタイプを指定。vbPicType
hImage As Long 'イメージのハンドル。
Option1 As Long 'ビットマップの場合は、パレットのハンドル。'メタファイルの場合は、幅。
Option2 As Long 'メタファイルの場合は、高さ。
End Type
Private Type TGUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(1 To 8) As Byte
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(lpPictDesc As TPICTDESC, _
RefIID As TGUID, _
ByVal fPictureOwnsHandle As Long, _
ByRef IPic As IPicture) As Long
'==================================================================================
Public Function Clipboard_GetMetafile() As StdPicture
Dim hEmf As Long
Dim TPICTDESC As TPICTDESC
Dim TGUID As TGUID
Set Clipboard_GetMetafile = Nothing
If IsClipboardFormatAvailable(CF_ENHMETAFILE) = False Then Exit Function
If OpenClipboard(CLng(0)) = False Then Exit Function
hEmf = GetClipboardData(CF_ENHMETAFILE)
Call CloseClipboard
If hEmf = 0 Then Exit Function
With TPICTDESC
.cbSizeofStruct = Len(TPICTDESC)
.picType = vbPicTypeEMetafile
.hImage = hEmf
End With
With TGUID
.Data1 = &H20400
.Data4(1) = &HC0
.Data4(8) = &H46
End With
Call OleCreatePictureIndirect(TPICTDESC, TGUID, True, Clipboard_GetMetafile)
End Function
別の標準モジュール（Module3）に表示用コンボボックスとイメージコントロールを作成するコード
'=================================================================================
Option Explicit
'=================================================================================
Sub sample1()
Dim nm As Name
Dim g0 As Long
Dim drp As DropDown
For Each nm In ThisWorkbook.Names
nm.Delete
Next
Worksheets("sheet1").Activate
With Worksheets("sheet1")
.DrawingObjects.Delete
For g0 = 1 To 100
Set drp = mk_list(.Range("a" & (10 * (g0 - 1) + 1)))
With drp
.Name = "drop" & g0
.OnAction = "set_image"
End With
DoEvents
Next
For g0 = 1 To 100
mk_img(.Range("c" & (10 * (g0 - 1) + 1) & ":d" & (10 * (g0 - 1) + 9))).Name = "img" & g0
Next
End With
End Sub
'=================================================================================
Function mk_list(ByVal rng As Range) As DropDown
Dim g0 As Long
Set mk_list = rng.Parent.DropDowns.Add(rng.Left, rng.Top, rng.Width, rng.Height)
With mk_list
For g0 = 1 To 30
.AddItem "shape" & g0
Next
.ListIndex = 1
End With
End Function
'=================================================================================
Function mk_img(rng As Range) As OLEObject
Set mk_img = rng.Parent.OLEObjects.Add(ClassType:="Forms.image.1", Link:=False _
, DisplayAsIcon:=False, Left:=rng.Left, Top:=rng.Top, Width:=rng.Width, Height:= _
rng.Height)
End Function
'=================================================================================
Sub set_image()
Dim imgnm As String
Dim txt As String
Dim dpnm As String
dpnm = Application.Caller
With ActiveSheet.DropDowns(dpnm)
txt = .List(.ListIndex)
End With
imgnm = Replace(dpnm, "drop", "img")
ActiveSheet.OLEObjects(imgnm).Object.Picture = LoadPicture(ThisWorkbook.Path & "\" & txt & ".bmp")
End Sub
以上です。まず、上記のコードをコピーして適当な名前でブックを保存してください。
保存後、mk_shapefileを実行してください。ブックと同じフォルダ上に任意の図形（オートシェイプ）を bmpファイルとして、保存します。
次にsample1を実行してください。Sheet1にコンボボックスとイメージコントロールをそれぞれ100個作成します。
これでコンボボックス変更して動作を確認してみてください。
うまくいくようなら、まず表示したい図形を保存することから、始めてください。
尚、API部分は、
http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=46923;id=excel
これを参考にさせてもらっています。
ichinose
なんだか無視されてるみたいだけど 例えば作った図形がSheet2に有るとして 単純に、いくつかの図形をコピーして Sheet1に100個ぐらい貼り付けた場合 動きに問題が無いのなら
'------
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Application.Intersect(Target, Range("A1:A3")) Is Nothing Then Exit Sub
On Error Resume Next
Shapes(Target.Address).Delete
On Error GoTo 0
If Target.Value <> "" Then
Sheets("Sheet2").Shapes(Target.Value).Copy
ActiveSheet.Paste
With Selection
.Name = Target.Address
.Top = Target.Top
.Left = Target.Offset(, 2).Left
End With
Target.Select
End If
End Sub
'------
こんなコードで良いのではないでしょうか。
因みに、A1:A3に入力規則を設定している事を想定しています。 また、「A1で選んでB1に表示」と書いて居られますが 隣のセルに表示すると、入力規則の▼が隠れて仕舞うので A1セルで選んだら、C1セルの位置にコピペします。
入力規則に設定したのと同じ名前の図形を Sheet2に用意しておいて下さい。
(HANA)
>こんなコードで良いのではないでしょうか。 ですね！！2000個の図形が頭に残ってたかな・・・、図形をブックから外すことが頭から離れませんでした。 それと、私は、ひとつのブックで図形を削除したり作成したり繰り返すコードは、ちょっと心配であまり書きません。excel2000のとき、繰り返し作成・削除をしていたらExcel落ちた経験があったもので・・・。 （もっともはっきり原因が特定できたわけではないですが）。 Excel2002でちょこっとテストしたけど、そんなこともなさそうですねえ・・・。
2000を超えるような数の図形になった時は、図形を外に出す方法も考えてみてください。
ichinose
先ほど、ようやくご提示頂いたコードを実行することができました。 まさに、理想通りの結果が得られ感動しております！これで作業の効率化が計れそうです。 今までは表の外に配置した図形をCtrl＋ドラッグで表に張り付けておりましたので。。。 これからお二人にご提示頂いたコードを大事に活用させていただきます。
今回ＶＢＡに触れたことで自分でもマクロを作ってみたいという欲が出てきました。 まずは入門書を片手に勉強に励みたいと思います。 またご質問させていただくこともあるかと思いますがよろしくお願いいたします。
大事なお時間を割いて頂いたことをお詫びするとともに深くお礼申しあげます。
ありがとうございました！！ （よっしー）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.