エクセル指定範囲画像保存

質問

win7　エクセル2013利用

デスクトップにAフォルダ作成→そのなかにB.xlsm作成
シート1、シート2がありシート2の指定範囲をjpgかpngで保存したい。(Aフォルダ\画像フォルダ　内)
繰り返し保存したいので、上書の警告などなく自動的に同じデータ名で上書してほしい。1.pngとかの名前。

範囲は広め(例A1:J40)です。

別ページで同じようなものがあったのですが、シート全て保存されてしまいます。
シート2だけに変更したかったのですが、知識不足でできなかったです。
申し訳ございませんがよろしくお願いします。

参考資料
Sub JPG_SAVE()
Dim ws As Worksheet, r As Range, ch As Chart
On Error Resume Next
For Each ws In ThisWorkbook.Worksheets
Set r = ws.Range("A1:M30")
r.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set ch = ws.ChartObjects.Add(0, 0, r.Width, r.Height).Chart
ch.Paste
ch.Export Filename:=ThisWorkbook.Path & "\" & ws.Index & ".jpg", filtername:="JPG"
ch.Parent.Delete
Next ws

End Sub

回答No.2

tsubu-yuki · ベストアンサー

なかなか回答がつかないようなので、暇つぶしに。

なんというか、色々試してみたらいいのに・・ですよ。

Dim ws As Worksheet, r As Range, ch As Chart
　　' エラー処理。エラーを無視して次に進む。
　　' しかしむしろ今回は「エラーは表示した方がきっと良い」ので、不要
　　'On Error Resume Next　
　　' ↓ ' 繰り返し処理開始、今回要らない
　　'For Each ws In ThisWorkbook.Worksheets
　　' 範囲指定
　　Set r = ActiveSheet.Range("A1:M30")
　　' ↓ 範囲を図としてコピー
　　r.CopyPicture Appearance:=xlScreen, Format:=xlPicture
　　' ↓ 空のグラフ領域を作成
　　'　サイズは選択領域の幅・高さ
　　Set ch = ActiveSheet.ChartObjects.Add(0, 0, r.Width, r.Height).Chart
　　' ↓ グラフ領域内に貼り付け
　　ch.Paste
　　' ↓ グラフ領域を図諸共ＪＰＧ画像にエクスポート
　　ch.Export Filename:="C:\Users\名前\Desktop\Aフォルダ\画像フォルダ\1.jpg", _
　　　　　　filtername:="JPG"
　　' ↓グラフ領域削除
　　ch.Parent.Delete

　　'Next ws ' ここまで繰り返し

ほぼ、ＶＢＡの基本として数えられる命令のみです。
いつも思う事ではあるのですが、読み取れないなら使うべきではないです。
私のように「悪意あるコード」を提示する輩もいますから。
当然、上記にも「悪意あるコード」が含まれているかもしれませんが、
不具合が起きても補償は一切いたしません。
お使いになるなら、自己責任でどうぞ。

お礼

ご回答ありがとうございました。
望みどおりの事が出来ました。
注釈もご記入いただき非常にわかりやすく理解できました。

おっしゃる通りでございます。
知識不足でご迷惑をおかけいたしました。

回答No.1

mt2015

貴方が作ったコードを直すのはやぶさかではありませんが、他人が作ったコードを貴方の要望通りに改造するのは気が引けます。
＃著作権云々まで行かなくても、この様な場に公開されることを前提としたコードなのかどうか等……

取りあえずこんな感じです。
ループをやめて、ファイル名を固定にして、Jpeg→pngに変更しただけです。
元のコードとの違いを確認してください。

Sub JPG_SAVE2()
　　Dim r As Range, ch As Chart
　　Set r = Worksheets(2).Range("A1:J40")
　　r.CopyPicture Appearance:=xlScreen, Format:=xlPicture
　　Set ch = ActiveSheet.ChartObjects.Add(0, 0, r.Width, r.Height).Chart
　　ch.Paste
　　ch.Export Filename:=ThisWorkbook.Path & "\1.png", filtername:="PNG"
　　ch.Parent.Delete
End Sub

お礼

ご回答ありがとうございました。
こちらの内容で思い通りの事が実現できました。
そしてご忠告とお心遣いありがとうございます。

完璧に望み通り出来たのですが、別の方が注釈もいれていただいていたので、そちらをBAにさせていただきました。

ですが、完璧に完成しておりましたので心苦しい限りです。
本当にありがとうございました。