【ExcelVBA】図の縮小貼付時のトラブル

このQ&Aのポイント
  • ExcelVBAで図の縮小貼り付けを行う際に、ある一定の行以降で図が正常に貼り付けられない現象に悩まされています。
  • セルを選択して実行し、縦横の比率を計算してセル内に貼り付けるマクロです。
  • 図を切り取りして貼り付ける作業を行っています。
回答を見る
  • ベストアンサー

【ExcelVBA】図の縮小貼付時のトラブル

ExcelVBAで「ActiveSheet.PasteSpecial Format:="図 (jpeg)"」という記述を使った際、 ある一定の行までは正常に図が貼り付けられるのですが、ある一定の行以降は図が 正常に張り付かない(つぶれた図になってしまう)現象に悩まされています。 ※正確には行数ではなく、選択したセルのselection.topの値が28000を超えた  あたりからおかしくなります(1行の高さが高いほど、低い行数から現象が発生します) もし何かしらの解決策を頂ければと思い、質問させて頂きました。 宜しくお願い致します。 マクロ自体は「セルを選択して実行し、図を選択すると、縦横の比率を計算してセル内に 貼り付けてくれる」という機能に、「ファイルサイズを縮小する為、貼り付けた図を一度 切り取りして、ペーストする」という作業を行っております。 Sub Paste_Picture() Dim CELL_WIDTH As Long Dim CELL_HEIGHT As Long Dim CELL_TOP As Long Dim CELL_LEFT As Long Dim CELL_PERCENTAGE As Single Dim PHOTO_WIDTH As Long Dim PHOTO_HEIGHT As Long Dim PHOTO_TOP As Long Dim PHOTO_LEFT As Long Dim PHOTO_PERCENTAGE As Single Dim PHOTO_FILE_NAME As String Dim myPHOTO As Object Application.ScreenUpdating = False Application.Calculation = xlCalculationManual PHOTO_FILE_NAME = Application.GetOpenFilename _ (Filefilter:="画像 ファイル(*.BMP;*.JPG;*.TIF), *.BMP;*.JPG;*.TIF") If PHOTO_FILE_NAME = "False" Then Exit Sub End If ActiveSheet.Select CELL_WIDTH = Selection.Width CELL_HEIGHT = Selection.Height CELL_TOP = Selection.Top CELL_LEFT = Selection.Left CELL_PERCENTAGE = CELL_HEIGHT / CELL_WIDTH Set myPHOTO = ActiveSheet.Pictures.Insert(PHOTO_FILE_NAME) PHOTO_WIDTH = myPHOTO.Width PHOTO_HEIGHT = myPHOTO.Height PHOTO_TOP = myPHOTO.Top PHOTO_LEFT = myPHOTO.Left PHOTO_PERCENTAGE = PHOTO_HEIGHT / PHOTO_WIDTH If CELL_PERCENTAGE > PHOTO_PERCENTAGE Then myPHOTO.Width = CELL_WIDTH * 0.95 myPHOTO.Height = CELL_WIDTH * PHOTO_PERCENTAGE * 0.95 myPHOTO.Cut ActiveSheet.PasteSpecial Format:="図 (jpeg)"        ←ここで図がおかしくなります。 Selection.Top = CELL_TOP + _ (CELL_HEIGHT - (CELL_WIDTH * PHOTO_PERCENTAGE * 0.95)) / 2 Selection.Left = CELL_LEFT + (CELL_WIDTH * 0.025) Else (中略) End If Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Set myPHOTO = Nothing End Sub

  • rg6ms
  • お礼率31% (6/19)

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

  • ベストアンサー
  • end-u
  • ベストアンサー率79% (496/625)
回答No.2

ぁっ。失礼.. : >CELL_PERCENTAGE = CELL_HEIGHT / CELL_WIDTH >Range("A1").Activate  '■ > >Set myPHOTO = ActiveSheet.Pictures.Insert(PHOTO_FILE_NAME) : Range("A1").Activate この1行だけで良かったのでした。

rg6ms
質問者

お礼

回答ありがとうございます。 お教え頂いた記述を追記して実行すると正常に動きました! a1を参照してselection.xxxの値を変更する事で正常に貼付 できるとは考えつきませんでした。。 本当にありがとうございました!

その他の回答 (1)

  • end-u
  • ベストアンサー率79% (496/625)
回答No.1

>※正確には行数ではなく、選択したセルのselection.topの値が28000を超えた > あたりからおかしくなります(1行の高さが高いほど、低い行数から現象が発生します) 簡易対応としては、Cut&Paste処理時の位置をA1セル付近でやれば良いです。 : Dim r As Range  '■追加 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual PHOTO_FILE_NAME = Application.GetOpenFilename _          (Filefilter:="画像 ファイル(*.BMP;*.JPG;*.TIF), *.BMP;*.JPG;*.TIF") If PHOTO_FILE_NAME = "False" Then   Exit Sub End If ActiveSheet.Select Set r = Selection  '■ CELL_WIDTH = r.Width  '□変更 CELL_HEIGHT = r.Height  '□ CELL_TOP = r.Top  '□ CELL_LEFT = r.Left  '□ CELL_PERCENTAGE = CELL_HEIGHT / CELL_WIDTH Range("A1").Activate  '■ Set myPHOTO = ActiveSheet.Pictures.Insert(PHOTO_FILE_NAME) : こんな感じ。 他には、Pictures.Insertメソッドではなく AddPictureメソッドを使って、位置を指定して画像挿入する方法でも良いかもしれません。 (その際はScaleWidth|ScaleHeightで元サイズにする必要があります)

関連するQ&A

  • Excel VBA チェックボックスの判断

    下記のようなマクロでチェックボックスを作成したのですが、その作成したチェックボックスをクリックしたときに、ある処理を実行させるようにするにはどうすればいいのでしょうか? よろしくお願いします。 Dim Max as Long Dim Cell as Range Dim Check as CheckBox ・ ・ ・ For i = 0 To Max   With Cell.Offset(i)   Set Check = ActiveSheet.CheckBoxes.Add_     (Left:=.Left,Top:=.Top, Width:=.Width, Height:=.Height)   End With   With Check   .LinkedCell = Cell.Address   .Caption = ""   .Value = False   End With Next

  • 大量の図変換でVBAが遅い

    Excel2007を使用しています。 ActiveXコントロール「Microsoftバーコードコントロール 9.0」にてバーコードを生成後、 図(拡張メタファイル)として変換するというVBAを作成しています。 動作としては完成したのですが、後半に行くに従い処理が遅くなっていきます。 スタート時は10個/秒ほどですが、 最後付近は2秒/個ほどになってしまいます。 手元の環境で、700個で240秒ほどかかります。 少しでも速度を改善させる方法はありますでしょうか。 バーコード生成部分はFunctionでサブルーチンから切りだしています。 サブルーチンでは、再描画の停止(ScreenUpdating = False)や、 手動計算への切換(Calculation = xlCalculationManual)は定義しています。 ------------------------------------------------------------------- Function ShowBarCode(P_Left As Long, P_Top As Long, P_Width As Integer, _ P_Height As Integer, P_Value As String, P_Style As Integer) Application.ScreenUpdating = False Dim mySht As Worksheet Set mySht = ActiveSheet Dim myShp1 As Object ' セルにバーコードを貼付ける Set myShp1 = mySht.OLEObjects.Add(ClassType:= _ "BARCODE.BarCodeCtrl.1", Link:=False, DisplayAsIcon:=False, _ Left:=P_Left, Top:=P_Top, Width:=P_Width, Height:=P_Height) With myShp1 .Object.Style = P_Style .Object.Value = P_Value .Width = .Width - 3   ' 再描画のための小細工 .Width = .Width + 3   ' 再描画のための小細工   End With ' バーコードを図(メタファイル)として変換 myShp1.Copy ActiveSheet.PasteSpecial Format:="図 (拡張メタファイル)", Link:=False, DisplayAsIcon:=False ' バーコードを削除 myShp1.Delete End Function ------------------------------------------------------------------- 添付図:バーコード付きシート サンプル

  • EXCEL2007で、回転された図を任意の場所に設定できない

    回転させた図を任意の場所に配置させたいのですが、EXCEL2007になってからShapeRange.Top/Leftに負の値が設定できなくなってしまったようで、任意の場所に配置できなくなってしまいました。 幸いIncrementTopやIncrementLeftには負の値が設定可能なようなのですが、Excel2003の場合とExcel2007の場合で動作が違うことには変わりなく、Excel2003ではTop/Leftの設定だけで済んだものがExce2007ではTop/Leftである程度の基準位置を設定したあと、さらにIncrementTop/IncrementLeftで補正の必要があるように思います。 こんなやり方をしないと図の配置はできないのでしょうか? 具体的には、マクロにて横長や縦長の長方形の図形を挿入し、位置を指定するのですが、図を回転した場合でもTop/Leftは、回転前の図のTop/Leftを設定するので、横長の図を90度回転させ縦長にした場合には、Leftに0を設定しても、回転後の結果の図は左端にはよっておらず、(元の図の横幅-元の図の縦幅)÷2の分だけ空いてしまいます。 なので、EXCEL2003では求められた空きの分だけLeftに負の値を設定するだけでよかったのですが、EXCEL2007ではLeftに負の値が設定できなくなっており、左端に寄せる事が不可能になっています。 以下、現象確認のための簡単なサンプルのマクロを示します。 '縦長の場合です ActiveSheet.Pictures.Insert("C:\TEMP\BITMAP.BMP").Select Selection.ShapeRange.LockAspectRatio = msoFalse Selection.ShapeRange.Height = 700 Selection.ShapeRange.Width = 100 Selection.ShapeRange.Rotation = 90# Selection.ShapeRange.Top = Range("B2").Top Selection.ShapeRange.Left = Range("B2").Left '横長の場合です ActiveSheet.Pictures.Insert("C:\TEMP\BITMAP.BMP").Select Selection.ShapeRange.LockAspectRatio = msoFalse Selection.ShapeRange.Height = 100 Selection.ShapeRange.Width = 700 Selection.ShapeRange.Rotation = 90# Selection.ShapeRange.Top = Range("B2").Top Selection.ShapeRange.Left = Range("B2").Left 内容はなんでもいいのでBITMAP.BMPという図のファイルを用意してください。 上記マクロは"B2"のセル位置が図形の左上を原点とするようにしたいのですが、全く違うところに図が配置されます。

  • 指定範囲をアクティブセルに変更(エクセル)

    以下のマクロで、A1:E20にある全ての図形を削除できます。 Sub test()  Dim wLeft As Long  Dim wTop As Long  Dim wRight As Long  Dim wBottom As Long  Dim s As Object  With Range("A1:E20")   wTop = .Top   wLeft = .Left   wBottom = .Top + .Height   wRight = .Left + .Width  End With  For Each s In ActiveSheet.DrawingObjects   With s    If wTop <= .Top And _      wLeft <= .Left And _      wBottom >= .Top + .Height And _      wRight >= .Left + .Width Then     .Delete    End If   End With  Next End Sub "With Range("A1:E20")"を、任意のアクティブセルに変更するにはどうすればいいでしょうか? ちなみに、"With ActiveCell"や"With Range(ActiveCell.Address)"では、うまくいきませんでした。

  • Shape画像保存モードの事後変更

    VBA Excel2007を使用しています。 画像を読み込むために、例えば、 Dim picture As Shape Set picture = ActiveSheet.Shapes.AddPicture(filename:=filename, LinkToFile:=msoTrue, SaveWithDocument:=msoFalse, Left:=Selection.Left, Top:=Selection.Top, Width:=0, Height:=0) のように、一旦、画像を「文書とともに保存しない」モードで読込み、後にそのShape画像を「文書とともに保存する」ように変更することは、可能でしょうか。

  • 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の高さと幅にフィットさせる。 これを実現させるにはどうしたらいいでしょう。

  • VBA

    選択したセルから複数画像を貼付け、画像の右セルに画像名を記入したいのですが、 画像名の記入方法がわからず、うまく動作できません。 ご教授の程、宜しくお願い致します。 例)A1セルを選択マクロ実行、画像3枚を貼付けたい:A1~A3セルに画像貼付け、B1~B3セルに画像名記入 ※※※※※※※※※※マクロ※※※※※※※※※※ Sub 画像貼付け() Dim i As Long, j As Long, k As Long Dim FileName As Variant Dim dblscal As Double Dim sp As Shape FileName = Application.GetOpenFilename( _ filefilter:="画像ファイル,*.jpeg;*.jpg;*.gif;*.JPG", _ MultiSelect:=True) Dim inp As Range On Error Resume Next Set inp = Application.InputBox( _ prompt:="マウスで開始セルを選択してください", _ Title:="開始セルを選択", _ Default:="マウスで開始セルを選択する", _ Type:=8) ''←メッセージボックスで開始セルを選択させる If Err.Number = 0 Then MsgBox mayrange.Address Else MsgBox "キャンセルしました。" End If j = inp.Row ''←選択した開始セルの行 k = inp.Column ''←選択した開始セルの列 For i = LBound(FileName) To UBound(FileName) Cells(j, k).Select With ActiveSheet.Shapes.AddPicture( _ FileName:=FileName(i), _ linktofile:=False, _ savewithdocument:=True, _ Left:=Selection.Left, _ Top:=Selection.Top, _ Width:=0, _ Height:=0) .ScaleHeight 1, msoTrue .ScaleWidth 1, msoTrue If Cells(j, k).Width / .Width < Cells(j, k).Height / .Height Then dblscal = WorksheetFunction.RoundDown(Cells(j, k).Width / .Width, 2) Else dblscal = WorksheetFunction.RoundDown(Cells(j, k).Height / .Height, 2) End If .Width = .Width * dblscal * 0.97 .Height = .Height * dblscal * 0.97 .Left = .Left + (Cells(j, k).Width - .Width) / 2 .Top = .Top + (Cells(j, k).Height - .Height) / 2 End With k = k + 0 j = j + 1 Next i End Sub

  • VBA 図の選択

    VBAについて質問です。 結合セルに画像を貼付けるとすべての画像が変更してしまいます。 ご教示をお願いいたします。 目的:結合セルに貼付る図だけを変更したい。 症状:下記のプログラムを実行すると、シート上のすべての図が変更してしまいます。 Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = "$D$5:$U$18" Then Call 図の挿入 '#1   '省略 If Target.Address = "$X$5:$AO$18" Then Call 図の挿入 '#12 End Sub Sub 図の挿入() Application.Dialogs(xlDialogInsertPicture).Show Call 図の貼付 End Sub Sub 図の貼付() Dim sp As Shape For Each sp In ActiveSheet.Shapes If sp.Type = msoPicture Then sp.LockAspectRatio = msoTrue sp.Top = sp.TopLeftCell.Top sp.Left = sp.TopLeftCell.Left If sp.Width * ActiveCell.MergeArea.Height / sp.Height < ActiveCell.MergeArea.Width Then sp.Height = ActiveCell.MergeArea.Height '--高さ基準 Else sp.Width = ActiveCell.MergeArea.Width '--幅基準 End If End If Next 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

  • エクセルのウインドウをど真ん中に表示したい

    Sub Macro2() Dim i As Long Dim j As Long i = Application.UsableHeight / 20 j = Application.UsableWidth / 40 With ActiveWindow .Top = i .Left = j End With With ActiveWindow .Height = i * 18 .Width = j * 38 End With End Sub これで、エクセルのアプリケーション内にウインドウを表示させたくて、 上下左右同じ長さの空白を入れたいのですが 左側の空白が多いです。 何故均等にならないのでしょうか?

専門家に質問してみよう