- ベストアンサー
エクセルを使って、トレーニング名に応じて画像を自動切換表示させたい
onlyromの回答
- onlyrom
- ベストアンサー率59% (228/384)
何度目の登場でしょうか、onlyromです。 ＞ちなみに入力規制というものが大きな原因になっていたということですが そうです、入力規則のドロップダウンリストを使うと、 Drop Down というコントロールがシートに１つ貼りつきます。 ところがこれは、 If pict.TopLeftCell.Address = "$E$3" Then この、TopLeftCellプロパティを持っていませんし 表面上表示されてないコントロールなので そのコードがエラーとなるわけです。 で、それを回避するために If Left(pict.Name, 7) = "Picture" Then If pict.TopLeftCell.Address = "$E$3" Then "Picture"、即ち画像だったら、TopLeftCellを訊く、としているわけです。 これで説明になっていますか？ ＞こういうものを作ればお客様も喜ぶし、 ＞仕事も簡素化されると思いやっていたのですが、 何事においてもそのような姿勢は非常に大切なことだと思います。 また分からないことがあったら遠慮なく質問してください。 ykdreamさんのように頑張っている人には誰もが親切に回答してくれることでしょう。 以上。
関連するQ&A
- VBAで同じ作業を２回繰り返す場合のコード
下記コードで具体的アドバイスを頂ければと思います。よろしくお願いいたします。 ■やりたいこと EXCELのシートに、２種類の写真表示スペースを作って、そのそばでそれぞれファイル名を入力して、そのファイル名を変えるごとに、それぞれのjpegファイルを表示させたい。 ■質問 下記コードで、ふたつめの変数を変えればよいことは、分かるのですが、どこをどのようにして、変数を変えればいいかわかりません。ご教授お願いします。 ■私の作っているコード とあるサイトを参考にして、下記作成いたしました。 'ひとつめ写真表示 Private Sub Worksheet_Change(ByVal Target As Range) Dim fName As String, pict As Shape If Target.Address <> "$H$25" Then Exit Sub fName = ThisWorkbook.Path & "\board_Image\" & Target.Offset(0, 0).Text If Dir(fName) = "" Then fName = ThisWorkbook.Path & "\board_Image\NoImage.jpg" End If With ActiveSheet For Each pict In .Shapes If pict.TopLeftCell.Address = "$C$26" Then pict.Delete Exit For End If Next pict Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _ .Range("k6").Left, .Range("C26").Top, 260, 320) End With End Sub ----------------------------------------------------------------------------- 'ふたつめ写真表示 Private Sub Worksheet_Change(ByVal Target As Range) Dim fName As String, pict As Shape If Target.Address <> "$AT$4" Then Exit Sub fName = ThisWorkbook.Path & "\map_Image\" & Target.Offset(0, 0).Text If Dir(fName) = "" Then fName = ThisWorkbook.Path & "\map_Image\NoImage.jpg" End If With ActiveSheet For Each pict In .Shapes If pict.TopLeftCell.Address = "$k$6" Then pict.Delete Exit For End If Next pict Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _ .Range("k6").Left, .Range("k6").Top, 260, 320) End With End Sub
- ベストアンサー
- オフィス系ソフト
- excel vbaの修正でアドバイスお願いします
excel2000を利用しています。 下記のとあるプロシージャで自分で修正を試みるもどうしても出来ず投稿させていただきました。 どうか修正内容のアドバイスをお願いします。 ■やろうとしていること 下記は写真を表示させる部分のコードです。下記 「worksheetchange」 イベントプロシージャで、レコードが変わると下記「myLoadPicture」が発生し、写真を表示させて、レコードを切り替えるたびに、その写真を切り替えるというものです。 ■相談したいこと いま指定したセルが空白だと、"NoImage.jpg"が表示されるようになっていますが、指定したフォルダに一致するファイルがなかった場合も、"NoImage.jpg"が表示されるようにしたいのですが、修正方法がわかりません。 どうかご教授お願いいたします。 Private Sub Worksheet_Change(ByVal Target As Range) Dim fRange As Range Dim touroku As Long Select Case Target.Address Case "$BC$1" Call hyouji Case "$BW$1" myLoadPicture "board_Image", Target.Text, Range("BH3") Case "$CY$1" myLoadPicture "circuit_Image", Target.Text, Range("CJ3") Case Else Exit Sub End Select End Sub Private Sub myLoadPicture(folderName As String, fname As String, targetRange As Range) On Error Resume Next Dim pict As Shape, picPath As String picPath = ThisWorkbook.Path & "\" & folderName & "\" & fname If fname = "" Then picPath = ThisWorkbook.Path & "\" & folderName & "\" & "NoImage.jpg" End If With ActiveSheet For Each pict In .Shapes If pict.TopLeftCell.Address = targetRange.Address Then pict.Delete Exit For End If Next pict Set pict = .Shapes.AddPicture(picPath, msoTrue, msoFalse, _ targetRange.Left, targetRange.Top, 260, 320) End With Exit Sub End Sub
- ベストアンサー
- オフィス系ソフト
- excel VBA のエラー回避のアドバイス依頼
いつもお世話になります。 EXCEL2000のVBAで、エラーになった場合の修正（回避コード）を教えていただきたくよろしくお願いいたします。 ここでは、とあるブックのSheet1のH25セルに写真のファイル名を入れます。そして、実際の写真を ブックが保管してあるフォルダ内のboard_image というフォルダに入れて、マクロを実行すると、C26セルに写真が表示されるというものですが。 ここで、C26セルが空白だと「実行時エラー'1004!; 指定したファイルが見つかりませんでした。」と言われます。 これを回避して、「NoImage.jpg」という名前の写真を表示させるようにしたいです。 アドバイスお願いします。 '■↓コードは下記です。 Private Sub Worksheet_Change(ByVal Target As Range) Dim fRange As Range Dim touroku As Long Select Case Target.Address Case "$H$25" myLoadPicture "board_Image", Target.Text, Range("C26") Case Else Exit Sub End Select End Sub Private Sub myLoadPicture(folderName As String, fname As String, targetRange As Range) Dim pict As Shape, picPath As String picPath = ThisWorkbook.Path & "\" & folderName & "\" & fname If Dir(picPath) = "" Then picPath = ThisWorkbook.Path & "\" & folderName & "\" & "NoImage.jpg" End If With ActiveSheet For Each pict In .Shapes If pict.TopLeftCell.Address = targetRange.Address Then pict.Delete Exit For End If Next pict Set pict = .Shapes.AddPicture(picPath, msoTrue, msoFalse, _ targetRange.Left, targetRange.Top, 300, 360) End With End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルの画像リンク解除
Pictures.Insert で書かれた内容を Shapes.AddPicture の構文に変更したいのですが、 VBAの知識が乏しいので、なかなかうまくいきません。 どなたかわかる方はいらっしゃいますでしょうか？ 宜しくお願いします。 Sub Test() Range("B3").Select Dim fName, pict As Picture fName = Application.GetOpenFilename("JPG, *.jpg", MultiSelect:=True) If IsArray(fName) Then For i = 1 To UBound(fName) Set pict = ActiveSheet.Pictures.Insert(fName(i)) pict.TopLeftCell = ActiveCell pict.Width = ActiveCell.Width * 2 pict.Height = ActiveCell.Height * 6 ActiveCell.Offset(7, 0).Activate Next i End If End Sub
- ベストアンサー
- Excel（エクセル）
- エクセルに画像挿入
以前の投稿で下記のようなVBAを拝見しました。 実行するとＡ列に画像ファイル名、Ｂ列に画像が縦に配置されます。 これを横に配置するにはどうすればいいのでしょうか？ 初心者なので質問不足かもしれませんがよろしくお願いします。 Sub PictAdd() Dim pict As Shape, r As Range With Application.FileSearch .NewSearch .LookIn = ThisWorkbook.Path .SearchSubFolders = False .Filename = "*.jpg" If .Execute() > 0 Then For i = 1 To .FoundFiles.Count Set r = ActiveSheet.Range("B" & i) Set pict = ActiveSheet.Shapes.AddPicture _ (.FoundFiles(i), msoTrue, msoFalse, _ r.Left, r.Top, r.Width, r.Height) pict.OnAction = "PictClick" r.Offset(0, -1).Value = Dir(.FoundFiles(i)) Next i End If End With Columns(1).EntireColumn.AutoFit End Sub
- ベストアンサー
- Visual Basic
- Excelでシート名と最終更新日を自動表示したい
Excelを使って （１）セルA1に入れた名目をシート名にし （２）セルH1には、最終更新日を自動で入れたいです。 調べた結果、 シート名を右クリックして「コードの表示」から （１）は Private Sub Worksheet_Change(ByVal Target As Range) Sheets(1).Name = Range("B1") End Sub を入れてうまくいきましたが、 （２）は Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) If ThisWorkbook.Saved = False Then Worksheets("Sheet1").Range("H1").Value = Date End If End Sub を入れてみましたが（←調べましたもの） うまくいきませんでした。 単純に、 Private Sub Worksheet_Change(ByVal Target As Range) Sheets(1).Name = Range("B1") End Sub Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) If ThisWorkbook.Saved = False Then Worksheets("Sheet1").Range("H1").Value = Date End If End Sub とつなげて入れるのではだめなんでしょうか？ それとも、（２）の何かが間違っていますか？ ご教授願います。
- ベストアンサー
- その他MS Office製品
- フォルダー内のファイルのリンク VBA
以前、カーソールを置いた部分のテキストとフォルダーの中にあるファイルが一致した場合、 ボタンを押す事によりハイパーリンクを付けるVBAを教えて頂き、現在も活用をさせて頂いています。 今までエクセル「E」列を対象にしていたのですが、 使用しているうちに前列に項目を入れたくなり「E」列の前に2列追加し、 対象の列が「E」列から「G」列の変更になりました。 それから新たにリンクを作成しようとしても実行出来なくなりました。 追加した前列を消しても駄目に。 素人なりに列を指定しているところを変えてみたのですが駄目でして。 If .Column <> 5 Or .Value = "" Then Exit Subを If .Column <> 7 Or .Value = "" Then Exit Subに。 列を変えた場合は、何処をどうすれば良いのでしょうか？ 申し訳ありませんが、教えて頂けないでしょうか？ 元のVBA Sub Test() Dim fName As String fName = ThisWorkbook.path & "\test\test-a\" With ActiveCell If .Column <> 5 Or .Value = "" Then Exit Sub fName = fName & .Offset(0, -4).MergeArea.Cells(1, 1).Value & _ "\" & .Value & ".prt" If Dir(fName) <> "" Then ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell, Address:=fName End If End With End Sub
- ベストアンサー
- その他MS Office製品
- エクセルＶＢＡについて
http://okwave.jp/qa/q7236213.html 上記質問の発展形なのですが 同様のことを Ｅ列に日付 Ｆ列に売上 Ｇ列に結果 でやりたいのですが この時Ａ列～Ｃ列のマクロも残したままでしたいのですが 下記のように同様のプロシージャーを下段に書けばできると思ったのですが うまくいきません。 Private Sub worksheet_change(ByVal Target As Excel.Range) If Target.Address <> "$A$1" Then Exit Sub If Target = "" Then Exit Sub Range("C10:C65536").ClearContents With Range(Cells(9 + Range("A1").Value, "C"), Cells(Range("A65536").End(xlUp).Row, "C")) .FormulaR1C1 = "=MAX(RC2:R[" & -Range("A1").Value + 1 & "]C2,FALSE)" .Value = .Value End With End Sub Private Sub worksheet_change(ByVal Target As Excel.Range) If Target.Address <> "$E$1" Then Exit Sub If Target = "" Then Exit Sub Range("G10:G65536").ClearContents With Range(Cells(9 + Range("E1").Value, "G"), Cells(Range("E65536").End(xlUp).Row, "G")) .FormulaR1C1 = "=MAX(RC6:R[" & -Range("A1").Value + 1 & "]C6,FALSE)" .Value = .Value End With End Sub どなたかお知恵を拝借できませんでしょうか？
- ベストアンサー
- オフィス系ソフト
- エクセルのコード表示についてですが。。
Private Sub Worksheet_Change(ByVal Target As Range) (1)If Target.Column <> 4 Then Exit Sub Target.Offset(0, -3) = Now() ⇒特定のセルに日時自動表示 (2)If Target.Column <> 4 Then Exit Sub Target.Offset(0, 1) = "DUMMY" ⇒特定のセルにDUMMYと自動表示 (3)If Target.Column = 4 Then Target.Offset(0, -2) = "1" Else ⇒特定のセルに１と自動表示 (4)If Target.Column = 35 Then Target.Offset(0, -2) = "2" ⇒特定のセルに２と自動表示 End If End If (5)If Target.Value = "T" Or Target.Value = "t" Then Target.Value = "田中" ⇒Tと入力すると田中と変換して表示 ElseIf Target.Value = "H" Or Target.Value = "h" Then Target.Value = "林" ⇒ｈと入力すると林と変換して表示 End If End Sub 上のようなコードを入力すると(3)と(5)が機能しません。。なぜでしょうか？？コードの表示がまずいのでしょうか？？
- 締切済み
- その他([技術者向] コンピューター)
- 【エクセルマクロ】画像挿入について教えてください。
Excel2010で下記マクロを実行し、 画像挿入元のフォルダ名を変更・削除したり、メールに添付して送信したりすると「リンクされたイメージを表示できません。ファイルが移動または削除されたか、名前が変更された可能性があります。リンクに正しいファイル名と場所が指定されていることを確認してください。」 と表示されます。 Excel2010では、Shapes.Addメソッドを使用するとリンク解除ができるとのことで、 初心者ながら色々試してみたのですが、うまくいきません。 マクロ初心者のため、詳しく教えていただけると大変助かります。 Private Sub Del_Btn_Click() 指定セル範囲 = "C18:K500" With ActiveSheet Set セル範囲 = .Range(指定セル範囲) For Each 図形 In .Shapes If 図形.Type = msoPicture Then Set 共有セル範囲 _ = Intersect(Range(図形.TopLeftCell, 図形.BottomRightCell), セル範囲) If Not (共有セル範囲 Is Nothing) Then 図形.Delete End If End If Next End With End Sub Private Sub Ins_Btn_Click() Dim fName As Variant Dim i As Long Dim j As Integer Dim k As Integer Dim Pict As Picture Const z1 As Long = 246 'サイズ指定 Const z2 As Long = 184 'サイズ指定 Dim z3 As Long '上位置 z3 = 306 k = 1 fName = Application.GetOpenFilename("JPGファイル, *.jpg", MultiSelect:=True) If IsArray(fName) Then Application.ScreenUpdating = False '配列に格納されたファイル名をソート BubbleSort fName, True 'If UBound(fName) >= 19 Then ' j = 19 ' Else j = UBound(fName) 'End If For i = 1 To j Set Pict = ActiveSheet.Pictures.Insert(fName(i)) If i Mod 6 = 5 Then z3 = z3 + 18.5 - k k = k + 0.5 End If If i Mod 2 = 1 Then With Pict .Width = z1 '横型 .Height = z2 '縦型 .Top = z3 + 146.5 * (i - 1) '上位置 .Left = 83 '左位置 .Locked = False ico = ico + z1 + 10 '間隔指定 End With Else With Pict .Width = z1 '横型 .Height = z2 '縦型 .Top = z3 + 146.5 * (i - 2) '上位置 .Left = 350 '左位置 .Locked = False ico = ico + z1 + 10 '間隔指定 End With End If ActiveCell.Offset(2, 0).Activate Application.StatusBar = "処理中：" & i & "/" & UBound(fName) & "枚目" Next i End If With Application .StatusBar = False .ScreenUpdating = True End With Set Pict = Nothing If i > 0 Then MsgBox j & "枚の画像を挿入しました", vbInformation End If End Sub '値の入替え Public Sub Swap(ByRef Dat1 As Variant, ByRef Dat2 As Variant) Dim varBuf As Variant varBuf = Dat1 Dat1 = Dat2 Dat2 = varBuf End Sub '配列のバブルソート Public Sub BubbleSort(ByRef aryDat As Variant, _ Optional ByVal SortAsc As Boolean = True) Dim i As Long Dim j As Long For i = LBound(aryDat) To UBound(aryDat) - 1 For j = LBound(aryDat) To LBound(aryDat) + UBound(aryDat) - i - 1 If aryDat(IIf(SortAsc, j, j + 1)) > aryDat(IIf(SortAsc, j + 1, j)) Then Call Swap(aryDat(j), aryDat(j + 1)) End If Next j Next i End Sub どうぞよろしくお願いいたします。
- 締切済み
- Excel（エクセル）
お礼
onlyromさん 遅い時間までありがとうございました。 最後まで本当にご丁寧にありがとうございました。 ドロップダウンリストが行く手を阻んでいたことが わかりました。私の基礎的知識が不足していますが、 概要はつかめました。 今回onlyromさんのような方に出逢えて本当に良かった です。 明日の目覚めが最高の予感がします。 では、おやすみなさい。