Excelで写真張り付けマクロを修正する方法| OKWAVE

エクセル　写真貼り付け　マクロ

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean) Cancel = True '===============画像選択 myF = Application.GetOpenFilename _ ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False) If myF = False Then MsgBox "画像を選択してください(終了)" 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 ネットでこのマクロを見つけて応用したいのですが教えてくださいセルをダブルクリックすると画像が選べて貼り付けできるのですが全部のセルに反応してしまいますセルの範囲指定したいのですがどうすればいいでしょうか？ (1)セル結合でＡ１：Ｄ７範囲だけにこのマクロを入れておきたい場合 (2)セル結合でＡ１：Ｄ７とＸ１：ＡＡ４までとか複数選択したい場合宜しくお願いします

マクロで画像挿入の質問です

マクロ　初心者です。ワークシート指定して、ダブルクリック等を使っての画像選択、貼り付け＆セルの大きさに合わせる）ことはできるのですが、ダブルクリック等ではなく、手動でマクロを実行して指定のセル（B37）に貼り付けることはできるでしょうか？（セルの大きさに画像が変換するのは生かしたまま） Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)を sub マクロ名（）にして、Moduleに貼り付けて実行したら myAD2 = Target.Address 上記場所でエラーになってしまいます。どのように変更したら、できるでしょうか？または、できる手段はないのでしょうか？ご教授お願いします。使用ベースマクロは以下です。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Cancel = True '===============画像選択 myF = Application.GetOpenFilename _ ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False) If myF = False Then MsgBox "画像を選択してください(終了)" 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

VBAの修正コードを教えてください（初心者）

いつもお世話になっております。下記のVBAコードを使わせて頂き、自分で作成したエクセルにセルに合わせて自動で画像データを添付するようにしたいのですが。 (1)タテヨコの縮尺を保持⇒セルに合わせて縦横の変倍を行う (2)又は、貼付部のセルのサイズは決まっているのでサイズを指定して貼り付けるとなるように修正したいのですが、なにぶんVBAは初心者なもので、全くわかりません。どなたかご指導を宜しくお願い致します。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean) Cancel = True '===============画像選択 myF = Application.GetOpenFilename _ ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False) If myF = False Then MsgBox "画像を選択してください(終了)" 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

教えてください。

教えてください。初めての投稿になります、書き込みなど不慣れ点あるかも知れませんが宜しくお願いいたします。エクセル2007のマクロ、ＶＢＡ書き込みについて指定された結合セルのみに画像挿入したいのです下記のＶＢＡではすべてのセルにたいして画像挿入されてしまいます、結合セル三か所のみ反映したいのですが。 rivate Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean) Cancel = True '===============画像選択 myF = Application.GetOpenFilename _ ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False) If myF = False Then MsgBox "画像を選択してください(終了)" Exit Sub End If '===============画像の掃除 For Each mySP In ActiveSheet.Shapes Debug.Print mySP.Name If InStr(mySP.Name, "Drop Down") = 0 Then myAD1 = mySP.TopLeftCell.MergeArea.Address myAD2 = Target.Address If myAD1 = myAD2 Then mySP.Delete End If 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 セル指定縦Ｂ９からＢ２１（１９５（２６０ピクセル）横ＢからＥ（４０．０２（３４０ピクセル）その他２つの結合セルがあります、サイズはすべて同じです縦Ｂ２４からＢ３６　　縦Ｂ３９からＢ５１横ＢからＥ　　　　　　　横ＢからＥ　何分素人ですので、どのランに書き込めばいいのかもわかりませんいろんなＶＢＡをコピーして貼り付けましたがうまくいきませんでした宜しくご享受お願いいたします。　　　

VBAの操作方法について教えてください（初心者）

いつもお世話になっております。以下のような操作をエクセルにおいて行いたいのですが。 (1)エクセルのセルをクリック！ (2)エクスプローラー起動！画像データを選択！ (3)セルに合わせて縦横変倍をかけてデータ（JPGデータ）を貼付！同様の操作が可能な以下のVBAが公開されていたので使わせて頂こうと考えているのですが、操作方法が分かりません。 VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "Sheet1" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = True Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean) Cancel = True '===============画像選択 myF = Application.GetOpenFilename _ ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False) If myF = False Then MsgBox "画像を選択してください(終了)" 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 作成したエクセルのVBエディタを開く⇒標準モジュールの作成⇒上記VBAをコピペ・・・正直わかりません。昨日一晩かけて調べたのですがわかりません。どなたか宜しくお願い致します。

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 ------------------------------------------------------------------------- お願いいたします。

excel　マクロ　画像挿入

以下のマクロでリンク貼り付けではない　画像挿入を作成しようと思いましたがエラーになります詳しい方　修正　お願いいたします当方のしたい事としましては選択したセルでのみに画像挿入　リンクではない画像貼り付け以下例では　B3,B17,B31,B46,B60,B74　セルをダブルクリックすればそこに画像を挿入です Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim myF As Variant Dim mySp As Object Dim myAD1 As String Dim myAD2 As String Dim myHH As Double Dim myWW As Double Dim myHH2 As Double Dim myWW2 As Double If Not Intersect(Range("B3,B17,B31,B46,B60,B74"), Target) Is Nothing Then myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif") Cancel = True '===============画像選択 myF = Application.GetOpenFilename _ ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False) If myF = False Then MsgBox "画像を選択してください(終了)" 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.Shapes.AddPicture(Filename:=myF, LinkToFile:=False, _ SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _ Width:=0, Height:=0) '★　とりあえず　縦横０で。 mySp.ScaleHeight 1, msoTrue '★元のサイズに戻す mySp.ScaleWidth 1, msoTrue '★元のサイズに戻す '===============タテヨコの縮尺を保持 If mySp.Width > Target.Width Then mySp.Width = Target.Width If mySp.Height > Target.Height Then mySp.Height = Target.Height '===============中央へ調整 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

エクセル２０１０　挿入画像の圧縮　VBA

お世話になります。エクセル２０１０を使用しています。写真帳を作成しダブルクリックすれば写真が挿入されるようVBAにて作成しましたが、写真の解像度が高いので挿入するたびに画像が圧縮するようにVBAを組みたいのですが、どなたかご教示ください。具体的には一同挿入した画像を一度コピーし、再度貼り付ける・・・という動作かなと考えているのですが、マクロの記憶では記録されず・・・困っております。現在の写真帳の構文は Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean) Dim myF As Variant Dim mySp As Object Dim myAD1 As String Dim myAD2 As String Dim myHH As Double Dim myWW As Double Dim myHH2 As Double Dim myWW2 As Double '挿入のセルを指定 If Application.Intersect(Target, Range("d6,d23,d40")) Is Nothing Then Exit Sub Cancel = True Application.ScreenUpdating = False End If '写真挿入 Next myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif") If myPic = False Then MsgBox "画像を選択してください" Exit Sub End If Set myRange = Target 'このセル範囲に収まるように画像を縮小する Application.ScreenUpdating = False With ActiveSheet.Shapes.AddPicture(myPic, False, True, myRange.Left, myRange.Top, myRange.Width, myRange.Height) rX = 0.85 rY = 1 If rX > rY Then .Height = .Height * rY Else .Width = .Width * rX End If .Left = .Left + (myRange.Width - .Width) / 2 '写真を横方向の中央に配置 .Top = .Top + (myRange.Height - .Height) / 2 '写真を縦方向に中央に配置 .ZOrder msoSendToBack '最背面へ移動 End With Application.ScreenUpdating = True Cancel = True End Sub 上記に.CUT　などを書き足せばよいのか・・・ →エラーばかりで動かなったので。。　こちらに質問することにしました。どうぞ、よろしくお願いします。

エクセル　マクロ

エクセルのある特定のセルをダブルクリックすると画像ファイルを参照しにいき貼りつけたい画像ファイル選ぶとそのセルの大きさに合わせて画像ファイルがそのセルに貼りつくというマクロが以下の通りなんですが Excel2003からExcel2007へ変更すると画像ファイルの貼りつく位置がダブルクリックしたセルではない所に貼りつくようになりました参照や大きさなどはちゃんと機能しているようですどこを変更すればよいでしょうか？ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Intersect(Target, Range('特定のセル)) Is Nothing Then Exit Sub Cancel = True Dim myPic Dim myRange As Range Dim rX As Double, rY As Double myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif") If VarType(myPic) = vbBoolean Then Exit Sub Set myRange = Target Application.ScreenUpdating = False With ActiveSheet.Pictures.Insert(myPic).ShapeRange rX = myRange.Width / .Width rY = myRange.Height / .Height If rX > rY Then .Height = .Height * rY Else .Width = .Width * rX End If .Left = .Left + (myRange.Width - .Width) / 2 .Top = .Top + (myRange.Height - .Height) / 2 End With Application.ScreenUpdating = True Cancel = True 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

VBAの内容の修正をお願いさせて頂きます

VBAの内容の修正をお願いしたく質問させて頂きます。知人にExcel200７でシートのアルバムに写真をクリックで貼り付けられ、また別に張り付けてあるボタンでフォルダーを選択するとフォルダー内の写真を一括貼り付けるVBAを作成してもらいました。ところがExcel2013で作成したものは他のPCで見られず、『リンク先が分からない・・・』と言った内容のメッセージが表示されます。張り付けたボタンをクリックすると、フォルダーの選択はできますが、その後『実行時”1004”　　PicturesクラスのInsertプロパティを取得できません』と言うメッセージが出ます。残念ながら知人もよくわかりません。表示内容がお分かりの方はぜひとも修正のご指導をお願いします。写真のアルバムはA4サイズに横２×縦４の8枚を並べています。セルの結合が8枚あり、その場所をクリックすることで1枚1枚貼り付けることができます。また、VBAでフォルダ内で番号順に並んでいる写真がばらばらに貼りついて今します。その部分も分かりましたら、よろしくお願いします。 VBA　左上表示：(General) 右上表示：画像貼り付け Sub 画像貼り付け() '===============フォルダ選択 Set myPath = CreateObject("Shell.Application") _ .BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, 0) If myPath Is Nothing Then Exit Sub If myPath.Items Is Nothing Then Exit Sub If myPath.Items.Item Is Nothing Then Exit Sub フォルダ = myPath.Items.Item.Path Set myPath = Nothing '===============画像の掃除 ' For Each mySP In ActiveSheet.Shapes ' myAD1 = mySP.TopLeftCell.MergeArea.Address ' myAD2 = Target.Address ' If myAD1 = myAD2 Then mySP.Delete ' Next 元シト = ActiveSheet.Name セル = Array("C4", "AO4", "C21", "AO21", "C38", "AO38", "C55", "AO55") i = 8 Set myFS = CreateObject("Scripting.FileSystemObject") For Each myF In myFS.GetFolder(フォルダ).Files myEXT = LCase(myFS.GetExtensionName(myF)) If myEXT = "jpeg" _ Or myEXT = "jpg" _ Or myEXT = "gif" _ Or myEXT = "tiff" _ Or myEXT = "bmp" _ Or myEXT = "png" _ Or myEXT = "tif" Then If i > 7 Then i = 0 Sheets(元シト).Copy after:=Sheets(Sheets.Count) End If '===============画像の貼り付け Set mySP = ActiveSheet.Pictures.Insert(myF) myMA = Range(セル(i)).MergeArea.Address '===============タテヨコの縮尺を保持 myHH = Range(myMA).Height / mySP.Height myWW = Range(myMA).Width / mySP.Width If myHH > myWW Then mySP.Height = Range(myMA).Height mySP.Width = Range(myMA).Width Else mySP.Height = Range(myMA).Height mySP.Width = Range(myMA).Width End If '===============中央へ調整 myHH2 = (Range(myMA).Height / 2) - (mySP.Height / 2) myWW2 = (Range(myMA).Width / 2) - (mySP.Width / 2) mySP.Top = Range(myMA).Top + myHH2 mySP.Left = Range(myMA).Left + myWW2 Set mySP = Nothing i = i + 1 End If Next Set myFS = Nothing End Sub

エクセル2007のマクロについて

B9に品番を入力するとA9に画像が自動挿入される所まではなんとか出来たのですが、同じくB10,B11,B12・・・と下の行にも同じように品番を入力すれば画像が自動挿入される様にするには,どうのようにすれば良いのでしょうか？宜しくお願い致します。　 A 　 B 9 画像品番 10 画像品番 11 画像品番 12 画像品番　　　・　　　・　　　・ Private Sub Worksheet_Change(ByVal Target As Range) Const ImagePath = "C:\Users\f\Desktop\画像\" If Intersect(Target, Range("B9")) Is Nothing Then Exit Sub Application.EnableEvents = False Dim codRange As Range Set codeRange = Range("B9") Dim picRange As Range Set picRange = Range("A9") Dim objPic As Picture For Each objPic In ActiveSheet.Pictures If objPic.Left >= picRange.Left And objPic.Left <= picRange.Left + picRange.Width _ And objPic.Top >= picRange.Top And objPic.Top <= picRange.Top + picRange.Height Then objPic.Delete Exit For End If Next picPath = ImagePath & codeRange.Value & ".jpg" If Dir(picPath, vbNormal) = "" Then picRange.Cells(1, 1).Value = "画像がありません" Else picRange.Select Sheets(1).Pictures.Insert(picPath).Select '画像ファイルの挿入 With ActiveSheet.Pictures(ActiveSheet.Pictures.Count).ShapeRange .LockAspectRatio = msoFalse .Parent.Visible = msoTrue .Left = picRange.Left .Top = picRange.Top .Height = picRange.Height .Width = picRange.Width End With picRange.Cells(1, 1).Value = "" End If Application.EnableEvents = True End Sub

エクセル貼付けの画像がメール添付で表示されません

下記のようなVBA（ネット公開されているものを利用させていただいています）を使用し、エクセルに画像を貼り付けています。画像を貼り付けたエクセルを保存後、メールに添付すると貼り付けた画像が表示されなくなります。ファイルの容量も少なく、エクセルに取り込んだ画像は、リンク貼り付けになっているのかと考えていますが、取り込んだ画像を埋め込むにはどのようにすればいいでしょうか。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _ Cancel As Boolean) Dim myPic Dim myRange As Range '画像を配置するセル範囲 Dim rX As Double, rY As Double myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif") If VarType(myPic) = vbBoolean Then Exit Sub Set myRange = Target 'このセル範囲に収まるように画像を縮小する Application.ScreenUpdating = False With ActiveSheet.Pictures.Insert(myPic).ShapeRange rX = myRange.Width / .Width rY = myRange.Height / .Height If rX > rY Then .Height = .Height * rY Else .Width = .Width * rX End If .Left = .Left + (myRange.Width - .Width) / 2 '写真を横方向の中央に配置 .Top = .Top + (myRange.Height - .Height) / 2 '写真を縦方向に中央に配置 End With Application.ScreenUpdating = True Cancel = True End Sub

エクセルのマクロで画像を貼り付け　

画像をエクセルに貼り付ける作業を行っています。マクロを使いファイル内の画像（約３０枚程度）を１列づつスペースを空け右方向に４枚１行スペースを空け３行目の左に戻りその位置よりまた１列づつスペースを空け右方向に４枚・・・・・これを繰り返しファイル内の画像をすべて貼り付けたいのですがうまく動作が出来ません。何卒ご教授の程よろしくお願いします。 ※マクロ 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

Excel2010でのマクロによる画像貼付について

エクセル2010で下記のマクロを実行し、一旦保存して再度開くと、「リンクされたイメージを表示できません。ファイルが移動または削除されたか、名前が変更された可能性があります。リンクに正しいファイル名と場所が指定されていることを確認してください。」と表示されます。検索したところ、Pictures.Insertでなく、2010では、Shapes.Addを使用するとの事ですが、マクロに詳しく無いため、どこを修正したらいいのかわかりません。大量の写真貼り付けがあるので、教えて頂けると大変助かります。どうぞよろしくお願いいたします。 Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean) '===============起動の合図 If ActiveCell.FormulaR1C1 = "画像" Then Cancel = True '===============画像選択 SSS = Application.GetOpenFilename _ ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False) If SSS = False Then MsgBox "画像を選択してください(終了)" Exit Sub End If '===============画像の貼り付け Set CCC = ActiveSheet.Pictures.Insert(SSS) '===============タテヨコの縮尺を保持 HH = Target.Height / CCC.Height WW = Target.Width / CCC.Width If HH > WW Then CCC.Height = CCC.Height * 0.99 CCC.Width = Target.Width * 0.99 Else CCC.Height = Target.Height * 0.99 CCC.Width = CCC.Width * 0.99 End If '===============中央へ調整 HH2 = (Target.Height / 2) - (CCC.Height / 2) WW2 = (Target.Width / 2) - (CCC.Width / 2) CCC.Top = Target.Top + HH2 CCC.Left = Target.Left + WW2 Set CCC = Nothing End If End Sub

エクセルに写真を挿入するVBA

エクセルで写真集を作るためのVBAですが、以下のVBAでは画像がリンク貼り付けになってしまいます。どうしたらエクセルファイルに画像を貼りこみで保存できるのでしょうか？よろしくお願いいたします。やりたいことは、まずダブルクリックでダイアログボックスを表示させ、挿入したい写真を選択、写真がセルに合わせた大きさに縮小、セルの中央に写真を配置。以上です。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _ 　　　　　　　　　　　　　　　　　　　　Cancel As Boolean) 　　Dim PicFile As Variant 　　Dim rX As Double, rY As Double 　　'［ファイルを開く］ダイアログボックスを表示　　PicFile = Application.GetOpenFilename( _ 　　　　　　　　　　　　"画像ファイル,*.jpg;*.jpeg;*.gif;*.tif;*.png;*.bmp") 　　If VarType(PicFile) = vbBoolean Then Cancel = True: Exit Sub 　　Application.ScreenUpdating = False 　　　　'画像を挿入　　With ActiveSheet.Pictures.Insert(PicFile) 　　　　rX = Target.Width / .Width 　　　　rY = Target.Height / .Height 　　　　If rX > rY Then 　　　　　　.Height = .Height * rY 　　　　Else 　　　　　　.Width = .Width * rX 　　　　End If 　　　　'セルの中央（横方向/縦方向の中央）に配置　　　　.Left = Target.Left + (Target.Width - .Width) / 2 　　　　.Top = Target.Top + (Target.Height - .Height) / 2 　　End With 　　　　Application.ScreenUpdating = True 　　Cancel = True End Sub

エクセル2007でのVBAについて

このたび目的としては、エクセルで工事用写真をリサイズして挿入してエクセルデータを作りたいのです。どのように進めたいかというと、一連の流れは以下の通りです。　　　（今とりあえず持っているエクセルデータの一部が添付画像です） 1．この画像の『余白』となっている部分をクリックする 2．写真の入っているフォルダを選択するウィンドウが出てくる 3．写真を選択 4．余白となっている部分にそのサイズでリサイズされた写真が自動的に挿入されるこの流れがVBAでは『Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim dlgAnswer As Boolean, x As Object, MyWidth As Single, MyHeight As Single If Target.Columns.Count = 4 And Target.Rows.Count = 12 Then Application.ScreenUpdating = False MyWidth = Target.Width MyHeight = Target.Height dlgAnswer = Application.Dialogs(xlDialogInsertPicture).Show For Each x In ActiveSheet.Shapes With x If .Width > MyWidth Then .LockAspectRatio = msoTrue .Width = MyWidth .Line.ForeColor.SchemeColor = 64 .Line.Visible = msoTrue End If End With Next Application.ScreenUpdating = True End If End Sub　』となっていました。私は、VBAやマクロについて全く詳しくないのですが、このVBAを他のデータで使おうとするとただ単にコピーすればいいのでしょうか？中身についても上のマクロは各シート毎に設定されているのは分かるのですが、こういった中身についても教えていただけるとありがたいです。分かり難くて申し訳ないのですが、よろしくお願いします。

ドロップダウンリストを設定すると他のマクロがエラーになる

マクロ初心者です（質問も初心者です）下記のマクロを（抜粋）を使用していましたが別のセルにドロップダウンリストを設定すると「実行時エラー’1004’」アプリケーション定義またはオブジェクト定義のエラーです　とでますなぜでしょうか？　対処方法があれば教えてください宜しくお願いします End If '===============画像の掃除 For Each mySP In ActiveSheet.Shapes myAD1 = mySP.TopLeftCell.MergeArea.Address myAD2 = Target.Address If myAD1 = myAD2 Then mySP.Delete Next

エクセルVisualBasicマクロ詳しい方

写真を特定のセルに貼り付けるのにダブルクリックでマイドキュメントがでるようにし、写真を貼り付けるとサイズを枠に調節するようにマクロをつくりました。問題なく出来るようになったのですが、ダブルクリックでマイドキュメントではなく、別の場所を指定するにはどこをどう変えればいいですか？現状は以下の通りです。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Intersect(Target, Union(Range("A1:A21"))) Is Nothing Then Exit Sub Cancel = True Dim myPic Dim myRange As Range '画像を配置するセル範囲 Dim rX As Double, rY As Double myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif") If VarType(myPic) = vbBoolean Then Exit Sub Set myRange = Target 'このセル範囲に収まるように画像を縮小する Application.ScreenUpdating = False With ActiveSheet.Pictures.Insert(myPic).ShapeRange rX = myRange.Width / .Width rY = myRange.Height / .Height If rX > rY Then .Height = .Height * rY Else .Width = .Width * rX End If .Left = .Left + (myRange.Width - .Width) / 2 '写真を横方向の中央に配置 .Top = .Top + (myRange.Height - .Height) / 2 '写真を縦方向に中央に配置 End With Application.ScreenUpdating = True Cancel = True End Sub

エクセル２００７のVBAの困りごと

教えてください。画像挿入時にエクセルのセルの大きさに合わせるマクロを使っているのですが、エクセル２０００、２００３では問題なく動くのですが、２００７だと、うまくVBAが動かず、画像が縮小・拡大されません。わかるかた教えてください。コード　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

Excelで写真張り付けマクロを修正する方法

【急】Excelで写真張り付けマクロを書き換えたい

質問者が選んだベストアンサー

お礼 2022/06/16 21:45

関連するQ&A

エクセル　写真貼り付け　マクロ

マクロで画像挿入の質問です

VBAの修正コードを教えてください（初心者）

教えてください。

VBAの操作方法について教えてください（初心者）

VBAの写真貼り付けコードについて教えてください。

excel　マクロ　画像挿入

エクセル２０１０　挿入画像の圧縮　VBA

エクセル　マクロ

Excelの写真貼り付け(90度回転)について

VBAの内容の修正をお願いさせて頂きます

エクセル2007のマクロについて

エクセル貼付けの画像がメール添付で表示されません

エクセルのマクロで画像を貼り付け

Excel2010でのマクロによる画像貼付について

エクセルに写真を挿入するVBA

エクセル2007でのVBAについて

ドロップダウンリストを設定すると他のマクロがエラーになる

エクセルVisualBasicマクロ詳しい方

エクセル２００７のVBAの困りごと

注目のQ&A

カテゴリ

あなたにピッタリな商品が見つかる！ OKWAVE セレクト

専門家に質問してみよう

Excelで写真張り付けマクロを修正する方法

【急】Excelで写真張り付けマクロを書き換えたい

質問者が選んだベストアンサー

お礼 2022/06/16 21:45

関連するQ&A

エクセル 写真貼り付け マクロ

マクロで画像挿入の質問です

VBAの修正コードを教えてください（初心者）

教えてください。

VBAの操作方法について教えてください（初心者）

VBAの写真貼り付けコードについて教えてください。

excel マクロ 画像挿入

エクセル２０１０ 挿入画像の圧縮 VBA

エクセル マクロ

Excelの写真貼り付け(90度回転)について

VBAの内容の修正をお願いさせて頂きます

エクセル2007のマクロについて

エクセル貼付けの画像がメール添付で表示されません

エクセルのマクロで画像を貼り付け

Excel2010でのマクロによる画像貼付について

エクセルに写真を挿入するVBA

エクセル2007でのVBAについて

ドロップダウンリストを設定すると他のマクロがエラーになる

エクセルVisualBasicマクロ詳しい方

エクセル２００７のVBAの困りごと

注目のQ&A

カテゴリ

あなたにピッタリな商品が見つかる！ OKWAVE セレクト

専門家に質問してみよう

エクセル　写真貼り付け　マクロ

excel　マクロ　画像挿入

エクセル２０１０　挿入画像の圧縮　VBA

エクセル　マクロ

エクセルのマクロで画像を貼り付け　