Results of 1 - 1 of about 71 for ExecuteExcel4Macro 閉じた｜開いて｜開かず (0.012 sec.)
executeexcel4macro (140), 閉じた (629), 開いて (4904), 開かず (263)
- [[20091121211947]]
- #score: 14119
- @digest: 2a774d41bfa59e26af71844be843121a
- @id: 46507
- @mdate: 2009-11-25T12:28:00Z
- @size: 20920
- @type: text/plain
- #keywords: autotype (45725), tpictdesc (43904), autoshape (28311), 図形 (10538), drawingobjects (6249), 一シ (6225), sample1 (5623), shape (4873), parent (4635), function (4553), 形を (3745), declare (3615), height (3497), rng (3480), ichinose (3305), ク貼 (3245), 示頂 (2708), width (2554), 同一 (2483), delete (2401), 正常 (2258), ェイ (2126), 配置 (2111), 画像 (2019), トロ (1949), cells (1905), イプ (1890), リン (1637), ンク (1608), private (1605), 力規 (1546), コン (1503)
- 『セル内容に応じて画像表示、変更』（よっしー）
初めて質問させていただきます。 建築資材の集計表を作っているのですが様々な形状があり、特に決まった名称がないため オートシェイプで作った図形でそれぞれのパーツを区別しています。 たとえばA1セルに"1"〜"5"のリストを設定し、選んだ内容によってB1セルに表示する 画像を変更するという感じです。 いろいろ調べた結果、図形を名前定義してindirect関数で図のリンク貼り付けをする。 という方法を見つけたのですが、 この方法では同一シート内に10個ほどリンク貼り付けを行うとエクセルがフリーズしてしまいます。（私だけ??） 集計表なので、最終的に100個ほど図形が並ぶ表を作りたいのです。 私はvbaに関しては全くの無知なのですがvbaによる貼り付けならば可能でしょうか? そもそもあんまり図形が得意ではないエクセルでは同一シート上に100個も図形を並べること自体無理があるのでしょうか? エクセル2007、windows vistaです。 よろしくお願いします! ---- 図形を貼り付けるのは、コピペで出来ると思います。 ＞A1セルに"1"〜"5"のリストを設定し、選んだ内容によってB1セルに表示する画像を変更する こう言うことをしたければ、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のセルD10に入力規則のリストが設定されています（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にあるそれぞれのセルにリンクする。というかたちになります。 図形を表示するセルがB列に、1〜20のリストが設定されたセルがA列に配置されます。 A1で「1」を選択するとB1に「1」に対応する図形が表示される。 A2で「5」を選択するとB2に「5」に対応する図形が表示される。 A3で再び「1」を選択するとB3にも「1」に対応する図形が表示される。 このような感じでリンクセルを増やしていったところ10ほど配置したところでエクセルがフリーズする 現象が発生したのです。ichinose様は相当エクセルに精通しておられるようですのでお伺いしたいのですが 私が未熟なりに考察するに、リンク貼り付けを増やしたことがフリーズを招く原因になったのではないかと 感じているのですが同じ処理をVBAで行ってもやはり同じ結果になるのでしょうか? もしくはVBAならばリンクに頼らず直接貼り付けを行うことが可能なのでしょうか? ---- 今、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 ---- ichinose様、回答ありがとうございます。 このような膨大な（私からみれば）データを30分で作り上げてしまわれたのですか! どうやら私とはレベルというか次元が違うようです。。。 現在Excelが入ったPCが手元にないのでご提示頂いたコードをすぐに実行できないのが 悔しいのですが、明日私の方でも実行し動作状況を報告させていただきます。 さらに、また別のアプローチでの方法も試して頂けるとのことで、恐縮ですが よろしくお願い致します。 質問の最初に書き込んだ理由上、同一シート上に複数の図形を 配置することがよくあるのですが一度ブックを閉じて再度開くと 配置がずれるという現象がよく発生するのですが、他のExcel関係の サイトでも同じ事例が多数報告されているようです。 これについては仕様のようですね。。。（衝突しました。。よっしー） ---- >データを30分で作り上げてしまわれたのですか 念のために、誤解のないように・・・。 30分は、このプログラムの処理にかかる時間ですよ! では、ActiveXControlのImageを使った方法です。結果としては、以下に記述する方法は、前回投稿の方法に比べて、快適な動作をします。 新規ブックにて試してください。 概要としては、表示したい図形は、すべてファイルとして（JpegでもGifでもbmp等）保存します。 これを「コントロールツールボックス」のイメージコントロールを使ってVBAで表示切替を行います。 尚、入力規則のリストの代わりに「フォーム」のコンボボックスを使います。 標準モジュール(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 ---- ichinose様、HANA様、回答ありがとうございます。 先ほど、ようやくご提示頂いたコードを実行することができました。 まさに、理想通りの結果が得られ感動しております!これで作業の効率化が計れそうです。 今までは表の外に配置した図形をCtrl+ドラッグで表に張り付けておりましたので。。。 これからお二人にご提示頂いたコードを大事に活用させていただきます。 今回VBAに触れたことで自分でもマクロを作ってみたいという欲が出てきました。 まずは入門書を片手に勉強に励みたいと思います。 またご質問させていただくこともあるかと思いますがよろしくお願いいたします。 大事なお時間を割いて頂いたことをお詫びするとともに深くお礼申しあげます。 ありがとうございました!! （よっしー）... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/200911/20091121211947.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97056 documents and 608292 words.
訪問者：