エクセルマクロでサイズを指定して画像を一括貼り付けしたいです。

前任者が作成したマクロです。写真のサイズを指定したいのですができません。私はマクロ初心者の為このコードは難しくて理解できません。どうかよろしくお願い致します。

Sub 複数画像の挿入()
Dim c, sr, sc, s, rr, pkfile, ar, ac, rc, ccc, ca0
On Error GoTo err
Set a = Application.InputBox("画像挿入するセル選択" _
& Chr(13) & Chr(10) & "複数選択可" _
, "複数画像の一括挿入(セル選択)", Selection.Address, , , , , 8)
Application.ScreenUpdating = False
a.Select
sr = Selection.Row
sc = Selection.Column
rr = sr
pkfile = Application.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 "ファイルが指定されていません", , "複数画像の一括挿入": End
For fi = 1 To UBound(pkfile)
If pkfile(fi) = False Then MsgBox "ファイルが指定されていません", , "複数画像の一括挿入": End
Next fi
n = ActiveSheet.Pictures.Count
Application.DisplayAlerts = False
ar = a.Address
ac = Range(ar).Count
fi = 1
If ac > 1 Then GoTo ech Else GoTo pc
ech:
ca0 = ""
For Each cc In ActiveSheet.Range(ar)
ca = Range(cc.Address).MergeArea.Address
rc = Range(ca).Rows.Count
ccc = Range(ca).Columns.Count
If rc > 1 Or cc > 1 Then
ca = Cells(Range(ca).Row + rc - 1, Range(ca).Column + ccc - 1).Address
End If
If ca0 = ca Then GoTo mne
ca0 = ca
ca = Range(cc.Address).MergeArea.Address
Range(ca).Select

g = ActiveSheet.Pictures.Insert(pkfile(fi)).Name
fl = pkfile(fi)
fi = fi + 1
If fi = UBound(pkfile) + 1 Then GoTo en

mne:
Next
Application.DisplayAlerts = True
a.Select
Exit Sub

pc:
For fi = 1 To UBound(pkfile)
ca = Cells(rr, sc).Address
Range(ca).Select
g = ActiveSheet.Pictures.Insert(pkfile(fi)).Name
fl = pkfile(fi)
rr = rr + 1
Next fi
Exit Sub
en:
Application.DisplayAlerts = True
Application.ScreenUpdating = False

a.Select
Exit Sub
err: MsgBox "選択が正しくありません"
End Sub

このQ&Aに関連する最新のQ&A

A 回答 (2件)

ついでに。


Sub 複数画像の挿入() の動作にちょっと興味を惹かれましたので
習作してみました。
期待動作が違っていたら、こちらは捨て置いてください。

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
    • good
    • 0
この回答へのお礼

ありがとうございました。
思い通りの動作になりました。感謝します。

お礼日時:2010/08/18 18:32

挿入する複数の画像全て同じサイズにしたい、という解釈で良いですか?



その前提で話をすすめます。
ご提示のマクロで望みの動作ができているなら、
サイズ指定マクロを作成して、その中で Sub 複数画像の挿入()を呼び出し、
最後にサイズ変更すれば良いです。

Sub macro()
  Dim W As Single 'ヨコ
  Dim H As Single 'タテ
  Dim mn As Long  '挿入前の枚数
  Dim i As Long

  W = Application.InputBox("写真サイズのヨコは?", Type:=1)
  H = Application.InputBox("写真サイズのタテは?", Type:=1)
  
  '挿入前の枚数を記憶しておいてSub 複数画像の挿入を呼び出す
  mn = ActiveSheet.Pictures.Count
  Call 複数画像の挿入

  With ActiveSheet.Pictures
    '挿入なしはExit Sub
    If .Count = mn Then Exit Sub
    For i = mn + 1 To .Count
      .Item(i).Select False
    Next
  End With
  '挿入写真のみ選択してサイズ変更
  With Selection.ShapeRange
    'W,Hとも指定した場合は縦横比変更して指定サイズに。
    If (W > 0) And (H > 0) Then
      .LockAspectRatio = msoFalse
      .Width = W
      .Height = H
    'Wのみ指定は縦横比を保持してWのみ変更
    ElseIf W > 0 Then
      .Width = W
    'Hのみ指定は縦横比を保持してHのみ変更
    ElseIf H > 0 Then
      .Height = H
    'どちらも指定しなければサイズ変更しない。
    Else
    End If
  End With
  ActiveCell.Activate
End Sub

こんな感じです。
上記はApplication.InputBoxを使ってユーザーにサイズを入力してもらう例ですが、
固定値でも構わない場合は、InputBoxを使わず直接Width,Heightを指定してください。
If (W > 0) And (H > 0) Then...等の条件分岐も必要なくなります。
    • good
    • 1

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

Qエクセルに画像を貼付け縮小する作業をマクロにしたいのですが、

エクセルに画像を貼付け縮小する作業をマクロにしたいのですが、
分からない部分があって困ってます。

(1)挿入したいセルにカーソルを合わせる
(2)マクロ
 挿入-図-ファイル-図の挿入-図の書式設定-サイズ-30%

この作業を覚えさせると以下になりました。

Sub Macro3()
ActiveSheet.Pictures.Insert("C:\Documents and Settings\デスクトップ\1.JPG") _
.Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 360#
Selection.ShapeRange.Width = 480#
Selection.ShapeRange.Rotation = 0#
End Sub

これだと、写真が指定されてしまいます。
マクロの途中で止まって任意の写真を都度選べるようにできますか?
膨大な量の写真をセルに並べていきたいのです。

エクセルに画像を貼付け縮小する作業をマクロにしたいのですが、
分からない部分があって困ってます。

(1)挿入したいセルにカーソルを合わせる
(2)マクロ
 挿入-図-ファイル-図の挿入-図の書式設定-サイズ-30%

この作業を覚えさせると以下になりました。

Sub Macro3()
ActiveSheet.Pictures.Insert("C:\Documents and Settings\デスクトップ\1.JPG") _
.Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 360#
Selection.ShapeRange.Width =...続きを読む

Aベストアンサー

私も画像の取り込みでマクロをいじった経験があります。
こういうのはどうでしょう?(今動作確認できないのですが…)

Sub test()
ActiveSheet.Pictures.Insert(Application.GetOpenFilename).Select
Selection.Height = Selection.Height * 0.3
Selection.Width = Selection.Width * 0.3
End Sub

QExcelのVBAで画像読込→サイズ変更がしたい。

Excel2003を利用して仕事の工事写真帳を作成していますがVBAでどうしても上手くいかない部分があるので教えていただければと思い投稿しました。
【仕様】工事写真帳は1シート構成、用紙1枚に3枚画像が入り、画像の右側には摘要欄があります。画像を読み込む位置をダブルクリックするとセルのサイズ(写真サイズに結合してあります)を取得して画像サイズを変更して格納します。
【問題点】2枚以上画像を読み込んだ状態で実行すると目的の画像のサイズが変更にならない場合があります。
画像を削除したことで画像の名前が重複するのが原因だというところまではわかるのですが対処方法がわかりません。アドバイスをお願いします。

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

gyo = ActiveCell.Row '画像読込位置の取得
Set scel = Cells(gyo, 3)

scel.Select 'セルサイズの取得
w = Selection.Width
h = Selection.Height

fname = Application.GetOpenFilename _
("画像ファイル,*.gif;*.jpg;*.bmp", 1, "画像ファイルを指定して下さい") '画像読込
If fname = False Then
Exit Sub
End If
ActiveSheet.Pictures.Insert(fname).Select
i% = Selection.Index


Selection.Name = "gazou" & i '画像に名前をつける
Set 画像 = ActiveSheet.Shapes("gazou" & i)


With 画像 '画像のサイズ変更
.LockAspectRatio = False
.Placement = xlFreeFloating
.Placement = xlMove
.Width = w
.Height = h
End With

Range("F" & gyo).Select '摘要欄へ移動

End Sub

Excel2003を利用して仕事の工事写真帳を作成していますがVBAでどうしても上手くいかない部分があるので教えていただければと思い投稿しました。
【仕様】工事写真帳は1シート構成、用紙1枚に3枚画像が入り、画像の右側には摘要欄があります。画像を読み込む位置をダブルクリックするとセルのサイズ(写真サイズに結合してあります)を取得して画像サイズを変更して格納します。
【問題点】2枚以上画像を読み込んだ状態で実行すると目的の画像のサイズが変更にならない場合があります。
画像を削除したことで画...続きを読む

Aベストアンサー

画像にわざわざ名前をつける必要はあるのでしょうか?
(以下は一部抜粋して、少しだけ手を入れました)

Dim pict As String
 ActiveSheet.Pictures.Insert(fname).Select
 pict = Selection.Name
 With ActiveSheet.Shapes(pict) '画像のサイズ変更
  .LockAspectRatio = False
  .Placement = xlFreeFloating
  .Placement = xlMove
  .Width = w
  .Height = h
 End With

これなら画像を繰り返し削除しても大丈夫に思います

Q任意フォルダから画像をすべてエクセルの指定マスに貼り付けをしたい

ネットでいろいろ検索し、試してみましたが自分の思うような仕上がりにならず困っています。

実施したい内容としては、マクロで
①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入
②マクロを開始するとフォルダを選ぶ画面が現れる
③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
④画像は、セルの大きさに合わせて自動調整される
というものです。

1枚ずつを選んでセルに自動調整で貼り付けるということは真似事でできましたが、希望の内容をできるようにしようとすると、かなり難易度が高くお手上げ状態です。
このプログラムをどのように改修すれば可能になるかお教えください。

Sub 図11()

Dim strFilter As String
Dim Filenames As Variant
Dim PIC As Picture

' 「ファイルを開く」ダイアログでファイル名を取得
strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
Filenames = Application.GetOpenFilename( _
FileFilter:=strFilter, _
Title:="図の挿入(複数選択可)", _
MultiSelect:=True)
If Not IsArray(Filenames) Then Exit Sub

' ファイル名をソート
Call BubbleSort_Str(Filenames, True, vbTextCompare)

' 貼り付け開始セルを選択
Range("B6").Select

' マクロ実行中の画面描写を停止
Application.ScreenUpdating = False
' 順番に画像を挿入
For i = LBound(Filenames) To UBound(Filenames)
Set PIC = ActiveSheet.Pictures.Insert(Filenames(i))

'-------------------------------------------------------------
' 画像の各種プロパティ変更
'-------------------------------------------------------------
With PIC
.Top = ActiveCell.Top ' 位置:アクティブセルの上側に重ねる
.Left = ActiveCell.Left ' 位置:アクティブセルの左側に重ねる
.Placement = xlMove ' 移動するがサイズ変更しない
.PrintObject = True ' 印刷する
End With
With PIC.ShapeRange
.LockAspectRatio = msoTrue ' 縦横比維持
' 画像の高さをアクティブセルにあわせる
' 結合セルの場合でも対応
.Height = ActiveCell.MergeArea.Height
End With

' 次の貼り付け先を選択(アクティブセルにする)[例:5個下のセル]
ActiveCell.Offset(5).Select

Set PIC = Nothing
Next i

' 終了
Application.ScreenUpdating = True

End Sub

よろしくおねがいします。
※マクロはほぼ初心者です。大体がネットからコピペをして使っている程度のレベルです。

ネットでいろいろ検索し、試してみましたが自分の思うような仕上がりにならず困っています。

実施したい内容としては、マクロで
①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入
②マクロを開始するとフォルダを選ぶ画面が現れる
③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
④画像は、セルの大きさに合わせて自動調整される
というものです。

1枚ずつを選んでセルに自動調整で貼り付けるということは真似事でできましたが、希望の内容をできるよう...続きを読む

Aベストアンサー

>①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入
>②マクロを開始するとフォルダを選ぶ画面が現れる
>③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
>④画像は、セルの大きさに合わせて自動調整される

①は、A2で始まり、横に4進み、下に2進むという数列を設けています。
②は、ご存知のShell のBrowseForFolderを利用しましたが、他にもあるでしょう。
問題は③かな。一応、 ''安全のため(上限を設定) という箇所を設けましたが、不要なら、コメント・アウトしてください。また、DoEvents も入れておきました。
④は、何も手を付けていません。
コメント・アウトした部分で不要なら削除してください。

'//
Sub 図11R()
 'No. 9024507
 Dim strFilter As String
 Dim Filenames() As Variant
 Dim fName As Variant, ext As String
 Dim PIC As Picture
 Dim k As Long, m As Long
 Dim i As Long, j As Long
 Dim cnt As Long
 Dim FirstRng As Range
 Dim r As Range
 Dim Sel_Folder As Object, Sel_Path As String
 cnt = 0 'カウントの初期値
 '貼り付け最初のセル
 Set FirstRng = Range("A2")
 
  Set Sel_Folder = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "フォルダを選択してください", 5)

  If Not Sel_Folder Is Nothing Then
    Sel_Path = Sel_Folder.Self.Path
  Else
   Exit Sub
  End If
 
 ' 「ファイルを開く」ダイアログでファイル名を取得
 ChDir Sel_Path
' strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
' Filenames = Application.GetOpenFilename( _
' FileFilter:=strFilter, _
' Title:="図の挿入(複数選択可)", _
' MultiSelect:=True)
 fName = Dir("*.*", vbNormal)
 Do While fName <> ""
  If fName <> "." And fName <> ".." Then
   ext = Mid(fName, InStrRev(fName, ".") + 1)
   If InStr(1, "jpg,jpeg,gif,bmp,png", ext, 1) > 0 And Not fName Like "#*" Then
    cnt = cnt + 1
    DoEvents
    ReDim Preserve Filenames(1 To cnt)
    Filenames(cnt) = fName
    ''安全のため(上限を設定)
    If cnt > 100 Then Exit Do
   End If
  End If
  fName = Dir()
 Loop
 If cnt = 0 Then Exit Sub
 
 ' ファイル名をソート
 Call BubbleSort_Str(Filenames, True, vbTextCompare)
 
 '' 貼り付け開始セルを選択
 'Range("B6").Select
 
 ' マクロ実行中の画面描写を停止
 Application.ScreenUpdating = False
 ' 順番に画像を挿入
 k = LBound(Filenames)
 m = UBound(Filenames)
 
 For j = 1 To Int(m / 4) + Abs(m Mod 4 > 0)
  For i = 1 To 4
   Set PIC = ActiveSheet.Pictures.Insert(Filenames(k))
   Set r = FirstRng.Cells(1 + (j - 1) * 2, i)
   
   '-------------------------------------------------------------
   ' 画像の各種プロパティ変更
   '-------------------------------------------------------------
   With PIC
    .Top = r.Top ' 位置:アクティブセルの上側に重ねる
    .Left = r.Left ' 位置:アクティブセルの左側に重ねる
    .Placement = xlMove ' 移動するがサイズ変更しない
    .PrintObject = True ' 印刷する
   End With
   With PIC.ShapeRange
    .LockAspectRatio = msoTrue ' 縦横比維持
    ' 画像の高さをアクティブセルにあわせる
    ' 結合セルの場合でも対応
    .Height = r.MergeArea.Height
   End With
   
   ' 次の貼り付け先を選択(アクティブセルにする)[例:5個下のセル]
   ' ActiveCell.Offset(5).Select
   
   Set PIC = Nothing
   k = k + 1
   If k >= m Then Exit For
  Next i
 Next j
 Application.ScreenUpdating = True
 ChDir ThisWorkbook.Path
End Sub

>①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入
>②マクロを開始するとフォルダを選ぶ画面が現れる
>③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
>④画像は、セルの大きさに合わせて自動調整される

①は、A2で始まり、横に4進み、下に2進むという数列を設けています。
②は、ご存知のShell のBrowseForFolderを利用しましたが、他にもあるでしょう。
問題は③かな。一応、 ''安全のため(上限を設定) という箇所を設けましたが、不要なら、コメント・アウトし...続きを読む

Q複数の画像ファイルを挿入したい

工事の仕事をしています。
報告書をエクセルで書いて出すのですが、
現場の写真を大量に撮影して貼り付けなければなりません。

「挿入」→「ファイルから」で一枚一枚貼り付けているのですが手間でなりません。

デジカメで撮影した写真なのでファイル名は連番です。
一括でワークシートにズラッと並べて挿入することはできないのでしょうか?

週末1-200枚の写真を貼る為に残業するのは堪えます。
良い知恵をお貸し下さい。

Aベストアンサー

工事写真票の作成ですか?報告書の提出時期ですものね。(^^;)

工事写真ということで、次の点が重要になるかと思います。

1. 貼付けられる順番
  工事の様子を時間を追って撮影している場合、順番が重要です。
2. リサイズの問題
  工事写真は正確性が求められます。リサイズする場合、縦横比を固定すべきです。

1と2をクリアしつつ、貼付けを楽にするには、EXCELではマクロしか解決方法がありません。個人的にはVIXをお勧めしますが、一応EXCELでのマクロをアップします。貼付け後のサイズはセルの高さにあわせています。必要があれば、コードをカスタマイズして下さい。

ただ、他の方からもご指摘があるとおり、EXCELに200枚の画像は無茶ですね。複数のブックに切り分けましょう。

なお、マクロ[InsertPictures]は#2.papayukaさんのコードをかなり拝借しておりますし、配列のソートプログラムも以前どこかで教えて頂いたものです。クイックソートの方が早いのですが、長くなるので、バブルソートで済ませています。


以下コード。

Option Explicit
Sub InsertPictures()
  
  Dim fName As Variant
  Dim i As Long
  Dim Pict As Picture

  fName = Application.GetOpenFilename("JPGファイル, *.jpg", MultiSelect:=True)
  If IsArray(fName) Then
    Application.ScreenUpdating = False
    '配列に格納されたファイル名をソート
    BubbleSort fName, True
    For i = 1 To UBound(fName)
      Set Pict = ActiveSheet.Pictures.Insert(fName(i))
      With Pict
        .TopLeftCell = ActiveCell
        .ShapeRange.LockAspectRatio = msoTrue
        'どちらかをコメントアウト
        .ShapeRange.Height = ActiveCell.Height 'セルの高さリサイズ
        '.ShapeRange.Width = ActiveCell.Width 'セルの幅にリサイズ
        ActiveCell.Offset(0, 1) = fName(i) 'ファイル名書込み
      End With
      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
  MsgBox i & "枚の画像を挿入しました", vbInformation

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

工事写真票の作成ですか?報告書の提出時期ですものね。(^^;)

工事写真ということで、次の点が重要になるかと思います。

1. 貼付けられる順番
  工事の様子を時間を追って撮影している場合、順番が重要です。
2. リサイズの問題
  工事写真は正確性が求められます。リサイズする場合、縦横比を固定すべきです。

1と2をクリアしつつ、貼付けを楽にするには、EXCELではマクロしか解決方法がありません。個人的にはVIXをお勧めしますが、一応EXCELでのマクロをアップします。貼付け後のサイズはセ...続きを読む

Qエクセルで画像を自動的に挿入

エクセルは一般人程度の知識しかありません。
わたしは、デジカメの画像をエクセルに貼り付けて印刷しています。
(A4で、サイズ変更をして)
今までは、画像を貼り付けて、サイズ変更して、1画像ずつ配置していました。
しかし画像数が多いと配置の作業が大変です。画像を選択するだけでサイズ変更して自動的に配置してくれる機能なんてないですかね?
よろしくお願いします。

Aベストアンサー

検索すればそこかしこに情報があると思います。
我田引水ですが、
http://okwave.jp/qa3864319.html
更に、上記記事中のリンク先では、マクロの作り方も含めて説明してくれていますので、ご覧下さい。

QVBAエクセルに貼り付けた画像をセルにあった大きさにしたい(等倍)

エクセル貼り付けた画像をセルにあった大きさにしたいのですが、
その際、縦と横の比率を変更したくありません。

縦と横の比率を変更せず、セルにおさまる最大の大きさで画像のサイズを
変えることは可能でしょうか。

-----------------------------------------------------------------------------
縦と横の比率が関係なく、セルいっぱいのサイズに画像の大きさを変更するVBAは
下記URLから見つけられたのですが、、、、、
http://q.hatena.ne.jp/1240648036

Aベストアンサー

No.1です。

>画像が置いてあるセル上で処理を行う

画像のどこを基準にするか?によってコードは変わってきますが、
画像の左上端のセルにその画像を縦・もしくは横いっぱいに配置するコードにしてみました。

Sub Sample2()
Dim mySp As Shape, myRng As Range
Dim myHgt As Double, myWdt As Double

For Each mySp In ActiveSheet.Shapes
With mySp
Set myRng = .TopLeftCell
myHgt = myRng.Height
myWdt = myRng.Width
.Top = myRng.Top
.Left = myRng.Left
.Height = myHgt
If .Width > myWdt Then
.Width = myWdt
End If
End With
Next mySp
End Sub

こんな感じではどうでしょうか?m(_ _)m

No.1です。

>画像が置いてあるセル上で処理を行う

画像のどこを基準にするか?によってコードは変わってきますが、
画像の左上端のセルにその画像を縦・もしくは横いっぱいに配置するコードにしてみました。

Sub Sample2()
Dim mySp As Shape, myRng As Range
Dim myHgt As Double, myWdt As Double

For Each mySp In ActiveSheet.Shapes
With mySp
Set myRng = .TopLeftCell
myHgt = myRng.Height
myWdt = myRng.Width
.Top = myRn...続きを読む

QエクセルVBAで画像を貼り付ける座標設定方法は?

Sheets("Sheet1")に貼り付けたJ-pegの画像(=シンボルマーク)を別なシートに貼り付けるのは下記のVBAで出来ました。ただ、これでは貼り付け先のシートのセルK12が、貼り付け元のK12と同じ位置でないと思った場所に張り付きません。
そこでセルで場所を指定するのではなく、座標のようなもので指定する方法はないものかと考えた次第です。
オートシェイプなどは座標指定で作成できるのですが、J-pegのような画像はどうすればいいのでしょうか?

Sub TEST()
Sheets("FACE").Shapes("シンボルマーク").Copy
ActiveSheet.Range("K12").Select
ActiveSheet.Paste
End Sub

Aベストアンサー

#1です。
>この場合、ファイルをエクセルにくっつけて渡すなんてこと
>はできないものでしょうか?(別々にではなくあくまでエク
>セルのブックに付属した形で)
Excelのブックに付属した形にするなら、コピーペーストする方がいいと思います。一旦挿入した画像を別途保存するのは、簡単には出来ないと思います。

複数のシートで同じような作業をするなら、次のような方法も考えられます。
Function CpyMrk(MrkNM As String, myTop As Single, myLeft As Single)
Sheets("FACE").Shapes(MrkNM).Copy
ActiveSheet.Paste
ActiveSheet.Shapes(MrkNM).Top = myTop
ActiveSheet.Shapes(MrkNM).Left = myLeft
End Function

Sub test()
CpyMrk "シンボルマーク", 10, 10
End Sub

Qエクセルに画像(JPG)を取り込む作業を簡単にしたい!!

エクセルに画像(JPG)を取り込むときに、その画像のファイル名をセルに入力するとその画像が取り込めますか??
毎回、挿入から画像のある場所を指定してやっているととっても時間がかかります・・・。
簡単にできる方法はないでしょうか??
マクロがわからないので、やさしく教えてもらえると助かります。

Aベストアンサー

画像挿入ダイアログをマクロで出したいなら、

Sub Test1()
  Application.Dialogs(xlDialogInsertPicture).Show
End Sub

単純に図の挿入ボタンをユーザー設定でツールバーに置いておくのと変わりませんが。

他には、
例えば画像のフルパスを入力したセルを選択し、下記のようなマクロを実行すると画像が挿入されます。

Sub Test2()
Dim pict
On Error Resume Next
  If Dir(ActiveCell.Text) = "" Then Exit Sub
  Set pict = ActiveSheet.Pictures.Insert(ActiveCell.Text)
  pict.Top = ActiveCell.Offset(0, 1).Top
  pict.Left = ActiveCell.Offset(0, 1).Left
End Sub

画像ソフトからのコピー&ペーストは止めた方が良いと思います。
挿入-図と比べて、同じ画像を取り込んでも画像の形式に関係なく出来上がるExcelのファイルサイズがまったく異なってきますので。

> どうしてこんな簡単なことができないのか・・。と思ってしまいます。

Excelは画像管理ソフトじゃないので、そんな機能は必要ないという判断なのでしょう。

画像挿入ダイアログをマクロで出したいなら、

Sub Test1()
  Application.Dialogs(xlDialogInsertPicture).Show
End Sub

単純に図の挿入ボタンをユーザー設定でツールバーに置いておくのと変わりませんが。

他には、
例えば画像のフルパスを入力したセルを選択し、下記のようなマクロを実行すると画像が挿入されます。

Sub Test2()
Dim pict
On Error Resume Next
  If Dir(ActiveCell.Text) = "" Then Exit Sub
  Set pict = ActiveSheet.Pictures.Insert(ActiveCell.Text)
  pict.T...続きを読む

Qエクセルの写真挿入時に「図の挿入」から挿入しています。 その際、元の写

エクセルの写真挿入時に「図の挿入」から挿入しています。 その際、元の写真データのピクセル数に関係なく自分が指定した大きさに設定し自動縮小や拡大して挿入する方法を教えてくだ

Aベストアンサー

VBAでなければ無理です

Sub 写真挿入()

Application.Dialogs.Item(xlDialogInsertPicture).Show

With Selection
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 250
.ShapeRange.Width = 325
End With
End Sub


選択したセルの左上を基点としてファイル選択ダイアログで選んだ
写真が張り付きます
数字部分を任意の値に設定すれば好きな大きさになります


VBAは VBEを起動して記載します

このスペースでは説明が難しいので
どこかのサイトを検索して探してください

マクロの使い方 みたいな検索文字でイケると思います

Qエクセル(2013)VBA-図の縦横比を変えずにセルにおさまる最大限の大きさにする

エクセル(2013)VBAを使って、画像を挿入し、挿入した画像を図として貼付けしているのですが、
その後、貼り付けた図をセルにおさまる最大限の大きさ(縦横比は変更しない)
に変更したいのですが、どのようなコードを書けば良いのかご教授頂きたいです。

今出来ているマクロは、ネットからコピーしてきたものの為、
私には知識が足りずカスタマイズができませんでした。。。
似たような質問があったのですが、そちらも私には理解できませんでした。。

以下が現在のコードです。”【質問】”と記載した箇所に入れるコードを教えて頂きたいです。

※画像を全て貼り付けてから、全ての画像のサイズをセルに合わせる。という方法は
 避けたく、都度取り込んだ画像のサイズを変えるようにしたいです。

何卒よろしくお願いいたします!!
------------------------------------------------------------------------------

Sub 画像とファイル名書き出し()

Dim fName As Variant
Dim i As Long
Dim Pict As picture
Dim mySp As Shape, myRng As Range
Dim myHgt As Double, myWdt As Double

'ファイル選択
fName = Application.GetOpenFilename("画像 ,*.emf; *.wmf; *.jpg; *.jpeg; *.jfif; *.jpe; *.png; *.bmp; *.dib; *.rle; *.gif; *.emz; *.wmz; *.pcz; *.tif; *.tiff; *.eps; *.pct; *.pict; *.wpg", MultiSelect:=True)

If IsArray(fName) Then
Application.ScreenUpdating = False
'配列に格納されたファイル名をソート
BubbleSort fName, True
For i = 1 To UBound(fName)
Set Pict = ActiveSheet.Pictures.Insert(fName(i))


With Pict
.TopLeftCell = ActiveCell
.ShapeRange.LockAspectRatio = msoTrue
.Cut
ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False


' <<<【質問】ここでセルにおさまる最大限の大きさ(縦横比は固定)に変更したいです>>>
'
'
'
'
'

ActiveCell.offset(0, 1) = fName(i) '保存場所&ファイル名
ActiveCell.offset(0, 2) = Dir(fName(i)) 'ファイル名
End With
ActiveCell.offset(1, 0).Activate
Application.StatusBar = "処理中:" & i & "/" & UBound(fName) & "枚目"

Next i
End If
With Application
.StatusBar = False
.ScreenUpdating = True
End With

Set Pict = Nothing
If i < 1 Then
MsgBox "0枚の画像を挿入しました", vbInformation

Else
MsgBox i - 1 & "枚の画像を挿入しました", 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

エクセル(2013)VBAを使って、画像を挿入し、挿入した画像を図として貼付けしているのですが、
その後、貼り付けた図をセルにおさまる最大限の大きさ(縦横比は変更しない)
に変更したいのですが、どのようなコードを書けば良いのかご教授頂きたいです。

今出来ているマクロは、ネットからコピーしてきたものの為、
私には知識が足りずカスタマイズができませんでした。。。
似たような質問があったのですが、そちらも私には理解できませんでした。。

以下が現在のコードです。”【質問】”と記載した箇...続きを読む

Aベストアンサー

こんにちは、以下のコードをコメント部にいれてみて下さい。

'ここから
'この行はとりあえずコメントにしました
'''''ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False

'変数設定はループの外(上の変数設定の部分)でして下さい
dim wWIDTH as long
dim wHIGHT as long
dim wRITU as double
dim MyShape as shape
dim oPIC as stdole.IPictureDisp

cells(i,1).select '<--- 画像を貼り付けるセルを選択しています

Set oPIC=LoadPicture(fName(i))

'指定したセルの高さに合わせる場合(今回は高さに合わせました)
wHIGHT=Selection.height 'セルの高さ
wRITU =wHIGHT/oPIC.height '比率=セルの高さ / 実画像の高さ
wWIDTH=int(oPIC.width*wRITU)

'指定したセルの横幅に合わせる場合
'' wWIDTH=Selection.width 'セルの幅
'' wRITU =wWIDTH/opic.width '比率=セルの幅 / 実画像の幅
'' wHIGHT=int(oPIC.height*wRITU)

Set MyShape=ActiveSheet.Shapes.AddPicture(Filename:=fName(i),LinkToFile:=False,SaveWithDocument:=True, _
Left:=Selection.Left,Top:=Selection.Top,Width:=wWIDTH,Height:=wHIGHT)
'ここまで

では頑張ってください

こんにちは、以下のコードをコメント部にいれてみて下さい。

'ここから
'この行はとりあえずコメントにしました
'''''ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False

'変数設定はループの外(上の変数設定の部分)でして下さい
dim wWIDTH as long
dim wHIGHT as long
dim wRITU as double
dim MyShape as shape
dim oPIC as stdole.IPictureDisp

cells(i,1).select '<--- 画像を貼り付けるセルを選択しています

Set oPIC=LoadPicture(fName(i))

'指定したセ...続きを読む


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング

おすすめ情報