- ベストアンサー
VBAによる写真の貼り付け
- VBAを使用して、EXCEL2010上の特定のセルに名前を選択すると、対応する写真を表示したいと考えています。しかし、コードの一部でエラーが発生してしまいます。
- 問題のコードは他の方のものを参考にしており、該当の写真を削除してから指定のセルに貼り付ける処理を行っています。
- 原因はわかりませんが、エラーの箇所に問題がある可能性があります。他の部分も教えていただけると助かります。
- みんなの回答 (2)
- 専門家の回答
関連するQ&A
- エクセルのマクロで画像を貼り付け
画像をエクセルに貼り付ける作業を行っています。 マクロを使いファイル内の画像(約30枚程度)を1列づつスペースを空け 右方向に4枚 1行スペースを空け 3行目の左に戻り その位置よりまた1列づつスペースを空け右方向に4枚・・・・・ これを繰り返しファイル内の画像をすべて 貼り付けたいのですがうまく動作が出来ません。 何卒ご教授の程よろしくお願いします。 ※マクロ Sub EggFunc_pasteDirImage() ' 変数定義 Dim fileName As String Dim targetCol As Integer Dim targetRow As Integer Dim targetCell As Range Dim shell, myPath Dim pos As Integer Dim extention As String Dim isImage As Boolean ' 選択セルを取得 targetCol = ActiveCell.Column targetRow = ActiveCell.Row ' フォルダ選択画面を表示 Set shell = CreateObject("Shell.Application") Set myPath = shell.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, "C:\Users\0602116.MS\Desktop\") Set shell = Nothing ' フォルダを選択したら... If Not myPath Is Nothing Then fileName = Dir(myPath.Items.Item.Path + "\") Do While fileName <> "" ' ファイル拡張子の判別 isImage = True pos = InStrRev(fileName, ".") If pos > 0 Then Select Case LCase(Mid(fileName, pos + 1)) Case "jpeg" Case "jpg" Case "gif" Case Else isImage = False End Select Else isImage = False End If ' 拡張子が画像であれば If isImage = True Then ' 貼り付け先を選択 Cells(targetRow, targetCol).Select Set targetCell = ActiveCell ' 画像読込み ActiveSheet.Pictures.Insert(myPath.Items.Item.Path + "\" + fileName).Select ' 画像が大きい場合、画像サイズをセル幅に合わせる If Selection.Width > targetCell.Width Or Selection.Height > targetCell.Height Then If Selection.Width / targetCell.Width > Selection.Height / targetCell.Height Then Selection.Height = Selection.Height * (targetCell.Width / Selection.Width) Selection.Width = targetCell.Width Else Selection.Width = Selection.Width * (targetCell.Height / Selection.Height) Selection.Height = targetCell.Height End If End If ' 表示位置をセル中央に移動 Selection.Top = targetCell.Top + (targetCell.Height - Selection.Height) / 2 Selection.Left = targetCell.Left + (targetCell.Width - Selection.Width) / 2 ' 貼り付け先行を+1 targetCol = targetCol + 2 End If fileName = Dir() Loop MsgBox "画像の読込みが終了しました" End If End Sub
- ベストアンサー
- Visual Basic
- VBAで画像を自動で切り替える方法
Excelで棚割表を作っています。商品コードを打つとその商品の画像を自動で表示させたいのですが、雑誌を見ながらコードをアレンジしてほぼ完成したのですが、「プロシージャーが大きい」とエラーが出てマクロを実行出来ません。 画像は100個程度あり、先に別のマクロで貼り付けてあります。 Private Sub Worksheet_Change(ByVal Target As Range) Dim ファイル As String If Intersect(Target, Range("A4")) Is Nothing Then ActiveSheet.Shapes("画像").Delete ファイル = "C:\保存場所\" & Range("A4").Value & ".jpg" Range("B5").Select ActiveSheet.Pictures.Insert(ファイル).Select Selection.ShapeRange.LockAspectRatio = msoTrue Selection.ShapeRange.Top = ActiveCell.Top Selection.ShapeRange.Left = ActiveCell.Left Selection.ShapeRange.Height = 97 Selection.ShapeRange.Width = 52.5 Selection.ShapeRange.Rotation = 0# Selection.ShapeRange.IncrementLeft 1.5 Selection.ShapeRange.IncrementTop 1.5 Selection.Name = "画像" End If (中略) Dim ファイル98 As String If Intersect(Target, Range("U60")) Is Nothing Then Exit Sub ActiveSheet.Shapes("画像98").Delete ファイル98 = "C:\保存場所\" & Range("U60").Value & ".jpg" Range("V61").Select ActiveSheet.Pictures.Insert(ファイル98).Select Selection.ShapeRange.LockAspectRatio = msoTrue Selection.ShapeRange.Top = ActiveCell.Top Selection.ShapeRange.Left = ActiveCell.Left Selection.ShapeRange.Height = 97 Selection.ShapeRange.Width = 52.5 Selection.ShapeRange.Rotation = 0# Selection.ShapeRange.IncrementLeft 1.5 Selection.ShapeRange.IncrementTop 1.5 Selection.Name = "画像98" End Sub 省ける箇所や分割する方法などありましたら教えてください。
- ベストアンサー
- オフィス系ソフト
- Excelの写真貼り付け(90度回転)について
xcelに写真のサイズを自動的に変更するマクロ、(セルの大きさに合わせて)を利用しています。 このマクロに対して写真を90度角度を変更して、写真を表示させたいのですが、どのようにすればよいのでしょうか? Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _ Cancel As Boolean) ActiveSheet.Unprotect Dim C As Range, cm As Range Application.ScreenUpdating = False For Each C In Selection Set cm = C.MergeArea If C.Address = cm.Item(1).Address Then If Application.Dialogs(xlDialogInsertPicture).Show = False Then Exit Sub With Selection .Left = cm.Left .Top = cm.Top .Height = cm.Height .Width = cm.Width End With End If Next Set cm = Nothing Application.ScreenUpdating = True Range("a1").Select End Sub
- 締切済み
- その他MS Office製品
- EXCELのVBAによる写真貼り付け時に重なる。
VBAの初心者です。 エクセルに写真データを貼り付けるVBAで、以下のマクロを実行するとシートの同じセル位置B5に、写真が2枚重なった状態となります。 セルのB5とH5の位置に写真をそれぞれ貼りつけるために、どのように修正すればよいのでしょうか?ご教授ください。 OS:Vista ソフト:Excel2007 Sub 写真ファイル呼び出し() ' Sheets("風景1").Select Range("B5").Select ActiveSheet.Pictures.Insert(Worksheets("風景写真").Range("o4").Value).Select With Selection Selection.ShapeRange.LockAspectRatio = msoTrue '縦横比を固定するコマンド Selection.ShapeRange.Width = 245 '縦横比固定、幅のみを指定する End With 'Sheets("風景2").Select Range("H5").Select ActiveSheet.Pictures.Insert(Worksheets("風景写真").Range("o5").Value).Select With Selection Selection.ShapeRange.LockAspectRatio = msoTrue '縦横比を固定するコマンド Selection.ShapeRange.Width = 245 '縦横比固定、幅のみを指定する End With End Sub
- ベストアンサー
- オフィス系ソフト
- VBAの写真貼り付けコードについて教えてください。
写真をダブルクリックで簡単に貼り付けられるVBAのプログラムを友人に貰ったのですが、 追加で図の外枠に黒の2.5ptくらいの線を縁取る文を追加しようと、マクロで記録したプログラムを 入れてみたのですが上手く動作しません。 コードが --------------------------------------------------------------------------------- Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean) Cancel = True If Target.MergeCells = False Then Exit Sub '===============画像選択 myF = Application.GetOpenFilename _ ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False) If myF = False Then Exit Sub End If '===============画像の掃除 For Each mySP In ActiveSheet.Shapes myAD1 = mySP.TopLeftCell.MergeArea.Address myAD2 = Target.Address If myAD1 = myAD2 Then mySP.Delete Next '===============画像の貼り付け Set mySP = ActiveSheet.Pictures.Insert(myF) '===============タテヨコの縮尺を保持 myHH = Target.Height / mySP.Height myWW = Target.Width / mySP.Width If myHH > myWW Then mySP.Height = mySP.Height * myWW mySP.Width = Target.Width Else mySP.Height = Target.Height mySP.Width = mySP.Width * myHH End If '===============中央へ調整 myHH2 = (Target.Height / 2) - (mySP.Height / 2) myWW2 = (Target.Width / 2) - (mySP.Width / 2) mySP.Top = Target.Top + myHH2 mySP.Left = Target.Left + myWW2 Set mySP = Nothing End Sub ------------------------------------------------------------------------- お願いいたします。
- 締切済み
- Visual Basic
- Excel VBA マクロ 画像(図)貼り付け
Excel2010にて、 VBA マクロ 画像(図)貼り付けを行いたいと思っています。 しかし、マクロを自動登録すると、ActiveSheet.Pictures.Paste.Selectになり、AddPicture ができません。 下記のマクロをAddPictureへ変換したいのですが、そのまま、InsertをAddpictureに変更してもエラーになってしまいます。 いい方法を教えてください(ToT)/~~~。 どうぞよろしくお願いします。 Sub Test() ' ' Test Macro ' Rows("4:4").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Selection.RowHeight = 150# Range("C4").Select ActiveSheet.Pictures.Insert( _ "E:\FolderA\fileC.gif"").Select ActiveSheet.Pictures.Paste.Select Range("D4").Select ActiveSheet.Pictures.Insert( _ "E:\FolderA\fileD.gif"").Select Selection.Cut Range("D4").Select ActiveSheet.Pictures.Paste.Select Range("E4").Select ActiveSheet.Pictures.Insert( _ "E:\FolderA\fileE.gif"").Select Range("E4").Select ActiveSheet.Pictures.Paste.Select Range("F4").Select ActiveSheet.Pictures.Insert( _ "E:\FolderA\fileE.gif"").Select ActiveSheet.Pictures.Paste.Select Range("G4").Select ActiveSheet.Pictures.Insert( _ "E:\FolderA\fileG.gif"").Select Selection.Cut ActiveSheet.Pictures.Paste.Select Range("H4").Select ActiveSheet.Pictures.Insert( _ "E:\FolderA\fileH.gif"").Select Selection.Cut ActiveSheet.Pictures.Paste.Select Range("I3").Select ActiveSheet.Pictures.Insert( _ "E:\FolderA\fileI.gif"").Select Selection.Cut ActiveSheet.Pictures.Paste.Select Range("J4").Select ActiveSheet.Pictures.Insert( _ "E:\FolderA\fileJ.gif"").Select Selection.Cut ActiveSheet.Pictures.Paste.Select Range("K3").Select ActiveSheet.Pictures.Insert( _ "E:\FolderA\fileK.gif"").Select Selection.Cut ActiveSheet.Pictures.Paste.Select Range("L3").Select ActiveSheet.Pictures.Insert( _ "E:\FolderA\fileL.gif"").Select ActiveSheet.Pictures.Paste.Select Range("M4").Select ActiveSheet.Pictures.Insert( _ "E:\FolderA\fileM.gif"").Select Selection.Cut ActiveSheet.Pictures.Paste.Select Range("N4").Select ActiveSheet.Pictures.Insert( _ "E:\FolderA\fileN.gif").Select Selection.Cut ActiveSheet.Pictures.Paste.Select End Sub
- 締切済み
- Visual Basic
- VBAでオートシェイプの制御?
エクセルマクロでセルにオートシェイプを張る方法を調べていて、ここで丁度いいのを見つけました。 http://oshiete1.goo.ne.jp/kotaeru.php3?q=808898 見つけた下記のマクロを実際にやってみました。 A1に1を入れるとB2にハートマークが出ます。 しかし、さらに2を入力してもB2のハートは削除されてくれません。 さらに1をいれると、ハートの上にハートが重なってしまいます。 1ならハート、それ以外の入力ならハートが消えるようにするにはどうすればいいのでしょうか? Private Sub Worksheet_Change(ByVal Target As Range) If Target <> Range("A1") Then Exit Sub If Target.Value = 1 Then With ActiveSheet.Range("B2") ActiveSheet.Shapes.AddShape(Type:=msoShapeHeart, _ Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height).Select End With End If End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルVBA オートシェイプを操作したいです
エクセルでセルの入力内容によって楕円をオートシェイプで出現させたいと思います。 http://oshiete1.goo.ne.jp/qa809742.htmlで見つかったものを参考にし、 Private Sub worksheet_Activate() Dim Shp As Shape Set P11 = Range("P11") If P11 Is Nothing Then Exit Sub If P11.Value = 1 Then For Each Shp In ActiveSheet.Shapes If Not Application.Intersect(Shp.TopLeftCell, _ Range("N14:N15")) Is Nothing Then Shp.Delete End If Next Shp With ActiveSheet.Range("N14:N15") ActiveSheet.Shapes.AddShape(Type:=msoShapeOval, _ Left:=.Left,TOP:=.TOP,Width:=.Width,Height:=.Height).Select Selection.ShapeRange.Fill.Visible = msoFalse End With Range("N14").Select Else For Each Shp In ActiveSheet.Shapes If Not Application.Intersect(Shp.TopLeftCell, _ Range("N14:N15")) Is Nothing Then Shp.Delete End If Next Shp End If If P11.Value = 2 Then For Each Shp In ActiveSheet.Shapes If Not Application.Intersect(Shp.TopLeftCell, _ Range("N16")) Is Nothing Then Shp.Delete End If Next Shp With ActiveSheet.Range("N16") ActiveSheet.Shapes.AddShape(Type:=msoShapeOval, _ Left:=.Left, TOP:=.TOP, Width:=.Width, Height:=.Height).Select Selection.ShapeRange.Fill.Visible = msoFalse End With Range("N16").Select Else For Each Shp In ActiveSheet.Shapes If Not Application.Intersect(Shp.TopLeftCell, _ Range("N16")) Is Nothing Then Shp.Delete End If Next Shp End If End Sub とつなげて見ました。 動くには動くのですが、データ元のセルがP11からT30と100セルあり、さらにP11に入力されるデータが1,2,3,4の4種類、AQ11に5,6,7,8,9の5種類などと、ばらばらです。 P11に1が入力されるとN14:N15(結合されています)に円が入り、2が入力されるとN16に円が入る。 Q11に5が入力されるとR13に円が入り、6が入力されるとR14:R15に円が入る・・・・のようにしたいのです。 一生懸命、セルNo.を打ち込んでいたら、 「コンパイルエラー:プロシージャが大きすぎます」とエラーが出てしまいました。 ループさせればよいのだろうと試してみたのですが、元のセルの指定方法や、オートシェイプの出現させるせるの指定方法がわかりません。 どのようにすれば、データー元の範囲を指定して、それに対応したセルにオートシェイプを出現させる事が出来るようになるでしょうか。 お知恵を貸していただけないでしょうか。よろしくお願い致します。
- ベストアンサー
- その他MS Office製品
- VBA Do Until内で値の貼り付けができない
Excel2003を使用しております。 コピー&値のペースト作業をやってくれるマクロを作成しております。 具体的には、名簿に公がついていれば、その3つ左の名前をD27へ値のみコピペし、 D27がすでに値があれば、D28に書くことを、D37までループするようにしております。 しかし困ったことに、Do Untilコードを使用しておりますが、このコードではなぜか値の貼り付けが出来なくなります。 Sub Ns公() Dim work As Range Set work = Selection If Selection.Value = "公" Then ActiveCell.Offset(0, -3).Select Selection.Copy Do Until Range("D37").Select Range("D27").Select If Selection.Value = "" Then Selection.PasteSpecial paste:=xlPasteValues work.Select Else ActiveCell.Offset(1).Select End If Loop If Range("D36").Value <> "" Then Do Until Range("I37").Select Range("I27").Select If Selection.Value = "" Then Selection.PasteSpecial paste:=xlPasteValues work.Select Else ActiveCell.Offset(1).Select End If Loop work.Select End If work.Select End If work.Select ActiveCell.Offset(1).Select End Sub 原因や対策をご教授いただけるとうれしいです。よろしくお願いします。
- ベストアンサー
- その他(プログラミング・開発)
- Excelでセル上の画像を別のセルにコピーするには
いつも楽しく勉強させていただいております。 つぎのような処理をしたいのですが、うまくいきません。 1.セル1の上にある画像をセル2の上にコピーする。 2.コピーした画像をセル2の高さと幅にフィットさせる。 まず、このようなマクロを考えてみました。 Range("A1").CopyPicture Range("C1").Select ActiveSheet.Paste ActiveSheet.Shapes(Selection.Name).LockAspectRatio = msoFalse ActiveSheet.Shapes(Selection.Name).Top = Range("C1").Top ActiveSheet.Shapes(Selection.Name).Left = Range("C1").Left ActiveSheet.Shapes(Selection.Name).Height = Range("C1").Height ActiveSheet.Shapes(Selection.Name).Width = Range("C1").Width これですと元の画像がA1のセルより小さい場合、周囲に余白がある形でコピーされてしまいます。 C1にコピーしたら余白はなしでC1の大きさいっぱいに画像を引き延ばしたい(あるいは縮小したい)のです。 そこで次のように変更してみました。 (上のプログラムと一番上の行のみが違います)。 ActiveSheet.Shapes("図 6").Copy Range("C1").Select ActiveSheet.Paste ActiveSheet.Shapes(Selection.Name).LockAspectRatio = msoFalse ActiveSheet.Shapes(Selection.Name).Top = Range("C1").Top ActiveSheet.Shapes(Selection.Name).Left = Range("C1").Left ActiveSheet.Shapes(Selection.Name).Height = Range("C1").Height ActiveSheet.Shapes(Selection.Name).Width = Range("C1").Width これもうまくいきません。 A1にある元の"図 6"は動かしたくないのに、勝手にB1の位置に移動してしまいます。 というのは、"図 6"という画像をコピーすると、同じ名前で画像ができちゃうんですね。 コピー元とコピー先の両方の画像に対して位置や高さを設定することになるようです。 ということで、 1.セル1の上にある画像をセル2の上にコピーする。 2.コピーした画像をセル2の高さと幅にフィットさせる。 これを実現させるにはどうしたらいいでしょう。
- ベストアンサー
- その他MS Office製品
お礼
ありがとうございました。無地解決しました
補足
ご回答いただき有難うございます。ご指摘通り修正しましたが PicturesクラスのInsertプロパティを取得出来ません(実行時エラー1004) ※ActiveSheet.Pictures.Insert(myFile).Selectにて停止してしまいます。 フォルダパス&ファイル名を確認しても間違い無いのですが