マクロ初心者です。画像一括挿入について

このQ&Aのポイント
  • マクロ初心者の方が画像を一括挿入する方法について悩んでいます。現在のコードでは画像の縦横比率を固定することができず、伸びた画像が挿入されてしまいます。どの部分を変更すればよいでしょうか。
  • 画像一括挿入のためのマクロを使っていますが、縦横比率を固定して挿入することができません。どのようにすれば解決できるでしょうか。
  • マクロを使って画像を一括挿入しようとしていますが、画像の縦横比率が固定されず伸びた画像が挿入されてしまいます。どのように修正すればよいでしょうか。
回答を見る
  • ベストアンサー

マクロ初心者です。画像一括挿入について

初めてマクロを使っております。 以下ネットで拾ってきましたコードなのですが、 行いたいのは (1)挿入するセルを選択(複数可) (2)画像を一括選択 (3)縦横比率を固定して挿入:横か縦の長さは自分で設定 ※今のコードですと(3)で比率の固定ができず、伸びた画像が挿入されてしまいます これを可能にするには、一体どこをどう変えたらよいのでしょうか。 慣れない画像編集に悪戦苦闘しております。 どなたかご教授いただけますと幸いです。 どうぞよろしくお願い致します。 Sub try()   Dim a  As Range   Dim cc As Range   Dim W  As Single   Dim H  As Single   Dim mx As Long   Dim fi As Long   Dim i  As Long   Dim pkfile   On Error GoTo extLine   With Application     Set a = .InputBox("画像挿入するセル選択" & vbLf & _              "複数選択可", _              "複数画像の一括挿入(セル選択)", _              Selection.Address, _              Type:=8)     pkfile = .GetOpenFilename("すべての図" & _              "(*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;" & _              "*.jpe;*.png;*.bmp;*.gif)," & _              "*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;" & _              "*.jpe;*.png;*.bmp;*.gif", 2, _              "挿入する図の選択(複数選択可)", , True)     If Not IsArray(pkfile) Then       MsgBox "ファイルが指定されていません", , _           "複数画像の一括挿入"       GoTo extLine     End If     W = .InputBox("ヨコ", Type:=1)     H = .InputBox("タテ", Type:=1)     .ScreenUpdating = False   End With   mx = UBound(pkfile)   fi = 1   For Each cc In a     If cc.Address = cc.MergeArea.Item(1).Address Then       Call picIns(cc, pkfile(fi), W, H)       fi = fi + 1       If fi > mx Then         Set cc = Nothing         Exit For       End If     End If   Next   For i = fi To mx     Set a = a(a.Rows.Count, 1).Offset(1)     Call picIns(a, pkfile(i), W, H)   Next extLine:   Set a = Nothing   Application.ScreenUpdating = False   With err()     If .Number <> 0 Then MsgBox .Number & ":" & .Description   End With End Sub Sub picIns(ByVal r As Range, _       ByVal s As String, _       ByVal W As Single, _       ByVal H As Single)   With ActiveSheet.Pictures.Insert(s).ShapeRange     If (W > 0) And (H > 0) Then       .LockAspectRatio = msoFalse       .Width = W       .Height = H     ElseIf W > 0 Then       .Width = W     ElseIf H > 0 Then       .Height = H     End If     .Left = r.Left     .Top = r.Top   End With End Sub

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

  • ベストアンサー
  • SI299792
  • ベストアンサー率48% (704/1454)
回答No.1

変更の必要はありません。 縦又は横に0を入力すれば、前の画像と同じ比率になります。 縦を指定したければ、横を0にします。横を指定したければ、縦を0にします。 縦横共に0を入力すれば、前の画像と同じ大きさになります。

gekiotikun
質問者

お礼

早急なお返事ありがとうございます。 完成が見え、初心者ながらに興奮しております。 お恥ずかしいのですが、ヨコを約2cmにしたい場合はヨコに入力すべき数値はいくつなのでしょうか…重ねて質問で申し訳ありません。 どうかご教授いただけましたら幸いです。

その他の回答 (1)

回答No.2

横入りで失礼します。 > ヨコを約2cmにしたい場合はヨコに入力すべき数値はいくつなのでしょうか… Application.CentimetersToPoints というメソッドを使うと楽ちんです。 例えば、2cmをポイントに直すなら   Application.CentimetersToPoints(2) といった具合に使います。 今回の場合、コレを使うと良いと考えられるタイミングは2か所。 ・変数W・Hに代入するタイミング  W = Application.CentimetersToPoints(.InputBox("ヨコ(cmで指定)", Type:=1)) ・画像の大きさを変えるタイミング  .Width = Application.CentimetersToPoints(W) このどちらかで使うのがベターと思われます。

関連するQ&A

  • Excel マクロ 写真挿入

    こんにちは Excel2003で使っていた写真を挿入するマクロで困っています。 2003では問題なく画像が挿入され配布先でも見れましたが、2010では写真の保存先(リンク)を貼ったことになり、自分のPCでは問題ないくても送付先で見ることが出来ません。 どこをどのように変更すれば宜しいでしょうか?よろしくお願い致します。 Sub 画像をまとめてサイズ指定挿入改() Dim a As Range Dim bb As Integer Dim cc As Range Dim W As Single Dim H As Single Dim mx As Long Dim fi As Long Dim i As Long Dim pkfile On Error GoTo extLine With Application bb = .InputBox("貼り付ける画像の枚数を入力してください。       ※最大10枚までです。", Type:=2) Select Case bb Case "1" Set a = Range("A1") Case "2" Set a = Range("A1,H1") Case "3" Set a = Range("A1,H1,a22") Case "4" Set a = Range("A1,H1,a22,h22") Case "5" Set a = Range("A1,H1,a22,H22,A43") Case "6" Set a = Range("A1,H1,a22,H22,A43,H43") Case "7" Set a = Range("A1,H1,a22,H22,A43,H43,A64") Case "8" Set a = Range("A1,H1,a22,H22,A43,H43,A64,H64") Case "9" Set a = Range("A1,H1,a22,H22,A43,H43,A64,H64,A85") Case "10" Set a = Range("A1,H1,a22,H22,A43,H43,A64,H64,A85,H85") Case Else MsgBox "枚数は1~10の数字で入力してください" GoTo extLine End Select pkfile = .GetOpenFilename("すべての図" & _ "(*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;" & _ "*.jpe;*.png;*.bmp;*.gif)," & _ "*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;" & _ "*.jpe;*.png;*.bmp;*.gif", 2, _ "挿入する図の選択(複数選択可)", , True) If Not IsArray(pkfile) Then MsgBox "ファイルが指定されていません", , _ "複数画像の一括挿入" GoTo extLine End If W = 320 H = 240 .ScreenUpdating = False End With mx = UBound(pkfile) fi = 1 For Each cc In a If cc.Address = cc.MergeArea.Item(1).Address Then Call picIns(cc, pkfile(fi), W, H) fi = fi + 1 If fi > mx Then Set cc = Nothing Exit For End If End If Next For i = fi To mx Set a = a(a.Rows.Count, 1).Offset(1) Call picIns(a, pkfile(i), W, H) Next extLine: Set a = Nothing Application.ScreenUpdating = False With Err() If .Number <> 0 Then MsgBox .Number & ":" & .Description End With End Sub Sub picIns(ByVal r As Range, _ ByVal s As String, _ ByVal W As Single, _ ByVal H As Single) With ActiveSheet.Pictures.Insert(s).ShapeRange If (W > 0) And (H > 0) Then .LockAspectRatio = msoFalse .Width = W .Height = H ElseIf W > 0 Then .Width = W ElseIf H > 0 Then .Height = H End If .Left = r.Left .Top = r.Top End With End Sub Private Sub CommandButton1_Click() 画像をまとめてサイズ指定挿入改 End Sub

  • Excel2010のマクロ使用時の画像が見れません

    Excel2010,マクロを使用して画像挿入をした時の画像が他のPC上で見れないです。どなたか助けてくださいませんか。 Excel2010,マクロを使用した画像挿入した時の画像が他のPCへ送った時に見れませんでした。 原因は画像がリンク付けさせているから他のPCだと見えなくなっているんだと思うんですが…… マクロに関しては初心者なので教えてくださる方がいらっしゃると助かります。 過去の類似した質問はだいたい見ましたがわかりませんでした。 解決したい点は ・Excelに画像挿入するときにリンク先から表示するのではなく、画像自体をExcelへ保存して 別のサーバー上で他の方が画像を見ることができるようにする 以上になります。 仕事上画像を1つのシートあたり1000枚以上必要なのでマクロが必須です。 どなたか助言をいただけることはできないでしょうか。 よろしくお願いします。 ※今使用しているマクロは下記のようになります。 すいません。これも他の方のマクロを少しいじったものです。 このどこかに問題点があると思うのですが… Sub 複数画像挿入_サイズ変更() Dim a As Range Dim cc As Range Dim W As Single Dim H As Single Dim mx As Long Dim fi As Long Dim i As Long Dim pkfile Const myHeight = 40 '行の高さ。0-409を指定。写真のサイズがこれで調整される。 Const myWidth = 20 '列の幅。0 - 255を指定。 On Error GoTo extLine With Application Set a = .InputBox("画像挿入するセル選択" & vbLf & _ "複数選択可", _ "複数画像の一括挿入(セル選択)", _ Selection.Address, _ Type:=8) pkfile = .GetOpenFilename("すべての図" & _ "(*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;" & _ "*.jpe;*.png;*.bmp;*.gif)," & _ "*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;" & _ "*.jpe;*.png;*.bmp;*.gif", 2, _ "挿入する図の選択(複数選択可)", , True) If Not IsArray(pkfile) Then MsgBox "ファイルが指定されていません", , _ "複数画像の一括挿入" GoTo extLine End If H = .InputBox("タテ", Type:=1) W = .InputBox("ヨコ", Type:=1) .ScreenUpdating = False End With mx = UBound(pkfile) fi = 1 For Each cc In a If cc.Address = cc.MergeArea.Item(1).Address Then Call picIns(cc, pkfile(fi), W, H) fi = fi + 1 If fi > mx Then Set cc = Nothing Exit For End If End If Next For i = fi To mx Set a = a(a.Rows.Count, 1).Offset(1) Call picIns(a, pkfile(i), W, H) Next extLine: Set a = Nothing Application.ScreenUpdating = False With Err() If .Number <> 0 Then MsgBox .Number & ":" & .Description End With End Sub Sub picIns(ByVal r As Range, _ ByVal s As String, _ ByVal W As Single, _ ByVal H As Single) With ActiveSheet.Pictures.Insert(s).ShapeRange If (W > 0) And (H > 0) Then .LockAspectRatio = msoFalse .Height = H .Width = W ElseIf W > 0 Then .Width = W ElseIf H > 0 Then .Height = H End If .Left = r.Left .Top = r.Top End With End Sub

  • 【エクセルマクロ】画像挿入について教えてください。

    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 どうぞよろしくお願いいたします。

  • エクセル マクロ 初心者です

    エクセルマクロ初心者です。 以下の2つの Private Sub Worksheet_Change(ByVal Target As Range)を1つのシートで実行させたいのですが、 当方、初心者なので組み合わせ方が分かりません。 よろしくお願いします。 ===No1=== Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Target = StrConv(Target, vbUpperCase) Application.EnableEvents = True End Sub ===No2=== Private Sub Worksheet_Change(ByVal Target As Range) Dim Ans As Integer If Target.Count = 1 Then Ans = MsgBox("コピーは禁止!!", vbCritical) MsgBox "データを消去します。" With Application .EnableEvents = False .Undo .EnableEvents = True End With End If If Target.Count = 1 Then Exit Sub Else MsgBox “複数セルのコピー禁止!" With Application .EnableEvents = False .Undo .EnableEvents = True End With End If End Sub ------------ 上記の2つを1つのシートで動作させたいのですが、うまくいきません。 単体では、動作します。

  • Excelの画像一括挿入マクロを改良したい

    以下の質問の回答者さんの頂戴し少し改変して、マクロでExcelの画像を一括挿入しています。 https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q12139845762 貼り付けるセルが一列に並び画像を連続して下に貼り付けるだけであればこちらのマクロで大丈夫なのですが、 貼り付けるセルが2列3行になり、 1番目の写真  2番目の写真 3番目の写真  4番目の写真 5番目の写真  6番目の写真 という風に貼り付けたいときにどうしたらよいのかがわかりません。 ActiveCell.Offset(21).Select の所で、セルの行が21下がって貼り付けられるということはわかるのですが… 使っているExcelファイルはいわゆるセルが方眼紙のようになっており、15行19列のセルを結合してそこに写真を貼り付けています。 1番目の写真を貼り付けた後に2列移動して貼り付けたいです。 ご教授いただければ幸いです。 使用しているマクロ↓ Sub ShpAdTest() Dim FNames As Variant, myShp As Shape Dim Fn As String, i As Long FNames = Application.GetOpenFilename( _ filefilter:="Image(*.jpg;*.gif;*.bmp;*.png),*.jpg;*.gif;*.bmp;*.png", _ Title:="図の挿入(複数選択可)", _ MultiSelect:=True) If Not IsArray(FNames) Then Exit Sub Call BubbleSort_Str(FNames, True, vbTextCompare) Application.ScreenUpdating = False For i = LBound(FNames) To UBound(FNames) PasteShp (FNames(i)) With ActiveSheet.Shapes(ActiveSheet.Shapes.Count) .LockAspectRatio = msoTrue .Placement = xlMove .DrawingObject.PrintObject = True .Height = ActiveCell.MergeArea.Height If .Width > ActiveCell.MergeArea.Width Then .Width = ActiveCell.MergeArea.Width End If .Top = ActiveCell.MergeArea.Top + (ActiveCell.MergeArea.Height - .Height) / 2 .Left = ActiveCell.MergeArea.Left + (ActiveCell.MergeArea.Width - .Width) / 2 End With ActiveCell.Offset(21).Select Next Call ShpCutPaste Application.ScreenUpdating = True End Sub Sub PasteShp(fname As Variant) Dim Shp As Shape Set Shp = ActiveSheet.Shapes.AddPicture( _ filename:=fname, _ linktofile:=False, savewithdocument:=True, _ Left:=Selection.Left, Top:=Selection.Top, _ Width:=0, Height:=0) Shp.ScaleHeight 1!, msoTrue Shp.ScaleWidth 1!, msoTrue Set Shp = Nothing End Sub Private Sub BubbleSort_Str( _ ByRef Source As Variant, _ Optional ByVal SortAsc As Boolean = True, _ Optional ByVal Compare As VbCompareMethod = vbTextCompare) If Not IsArray(Source) Then Exit Sub Dim i As Long, j As Long Dim vntTmp As Variant For i = LBound(Source) To UBound(Source) - 1 For j = LBound(Source) To LBound(Source) + UBound(Source) - i - 1 If StrComp(Source(IIf(SortAsc, j, j + 1)), _ Source(IIf(SortAsc, j + 1, j)), Compare) = 1 Then vntTmp = Source(j) Source(j) = Source(j + 1) Source(j + 1) = vntTmp End If Next j Next i End Sub ' ↓ 画像のリンク解除と画像ファイルサイズの低減 Private Sub ShpCutPaste() Dim Shp As Shape, Nm As String Dim x As Double, y As Double Application.ScreenUpdating = False For Each Shp In ActiveSheet.Shapes With Shp x = .Left y = .Top Nm = .Name .Cut End With ActiveSheet.PasteSpecial Format:="図 (JPEG)", _ Link:=False, DisplayAsIcon:=False With Selection .Left = x .Top = y .Name = Nm End With Application.CutCopyMode = False Next Application.ScreenUpdating = True 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) '★ とりあえず 縦横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

  • マクロで二つの構文を繋ぐには

    いつもお世話になります。 WIN7 EXCELL2010 です。 Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) If Target.Address = "$A$1" Then Sh.Name = Target.Range("A1").Value End Sub ThisWorkbook に上記のマクロに下記のマクロを追加したいのですが、 End Sub の ところを End If End With などに変えたのですがうまくゆきません。 御指導お願いできませんでしょうか。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim myRange As Range Set myRange = Intersect(Target, Range("M3:V27")) If Not myRange Is Nothing Then Select Case Target.Value Case "" Target.Value = "○" Case "○" Target.Value = "●" Case Else Target.ClearContents End Select Cancel = True End If End Sub 宜しくお願いいします。

  • 複数のエクセルシートをまとめるマクロ

    下は複数のエクセルファイルを一つにするマクロですが、100万件を超えるためcsvで保存するようにするにはどこを変更したらよいでしょうか。 よろしくお願いします。 Sub Sample() Dim t As Single Dim strPath As String Dim strFileName As String Dim WB1 As Workbook Dim WS1 As Worksheet Dim WS2 As Worksheet Dim lngRowCount As Long 'A列に値が入っているデータ数 t = Timer 'まとめたいシート Set WS2 = ThisWorkbook.Worksheets(1) strPath = ThisWorkbook.Path strFileName = Dir(strPath & "\*.xls*") Do While strFileName <> "" If strFileName <> ThisWorkbook.Name Then Set WB1 = Workbooks.Open(strPath & "\" & strFileName) Set WS1 = WB1.Worksheets(1) With WS1.Range("A1") lngRowCount = .Worksheet.Cells(.Worksheet.Rows.Count, .Column).End(xlUp).Row - .Row If lngRowCount >= 1 Then With .Resize(lngRowCount, 14).Offset(1) .Copy WS2.Range("A" & WS2.Rows.Count).End(xlUp).Offset(1) End With End If End With WB1.Close False End If strFileName = Dir Loop MsgBox "まとめ処理をしました。処理時間 " & Format((Timer - t) / 60 / 60 / 24, "h:mm:ss") End Sub

  • H列の画像の下に画像を挿入できるようにしたい

    H列の画像の下に画像を挿入できるようにしたいです。 マクロを組んでみたのですが、A列に画像があった場合、 その下に画像が挿入されてしまいます。 H列のみで判断して挿入するにはどうすればよろしいでしょうか。 Sub 改修後写真添付() Dim FileName As Variant Dim I, F, endRow As Long Dim sheetName As String Dim shp As Shape sheetName = ActiveSheet.Name FileName = Application.GetOpenFilename(MultiSelect:=True) On Error GoTo err_shori If Range("H5") = "" Then I = 5 Range("H5").Value = "画像添付" Else For Each shp In ActiveSheet.Shapes endRow = Application.Max(endRow, shp.BottomRightCell.Row) Next I = 2 + endRow End If For F = 1 To UBound(FileName) With Sheets(sheetName).Pictures.Insert(FileName(F)) .Top = Range("H" & I).Top .Left = Range("H" & I).Left .Width = "170" .Height = "165" .Cut End With With Sheets(sheetName) .Range("H" & I).Select ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False End With I = I + 14 Next F MsgBox UBound(FileName) & "個の画像ファイルが挿入されました。" Exit Sub err_shori: MsgBox "キャンセルされました。" End Sub

  • エクセル2010 挿入画像の圧縮 VBA

    お世話になります。 エクセル2010を使用しています。写真帳を作成しダブルクリックすれば写真が挿入されるよう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 などを書き足せばよいのか・・・ →エラーばかりで動かなったので。。  こちらに質問することにしました。 どうぞ、よろしくお願いします。

専門家に質問してみよう