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

質問

エクセルで写真帳を作成してるのですが、
保存容量が大きいため、下記のマクロをコピペしたのですが
画像は消えてしまい困ってます。

(1)どなたか下記のマクロ解読お願いします。
(2)それと、新しく保存すると、jpegの画像が消えてしまい
　どうしたらよいかわからない。
(3)ボタンを作成してまして、これも消したい。
　オブジェクト削除なのかなぁ？
わがまま言ってすいません。自分には無理なんでお願いします。

Option Explicit
Sub Macro1()
Dim SheetCount As Integer
Dim i As Integer
Dim fname As String
Dim Ws As Worksheet
Dim OrgWorkBook As Workbook
Dim NewWorkBook As Workbook

SheetCount = Worksheets.Count
ChDir "C:\Documents and Settings\たかじん\デスクトップ"
fname = Application.GetSaveAsFilename _
(, "Microsoft Excel ブック (*.xls), *.xls")
If fname = "False" Then Exit Sub

Set OrgWorkBook = ActiveWorkbook
Workbooks.Add (xlWBATWorksheet)
Set NewWorkBook = ActiveWorkbook
For i = 2 To SheetCount
Sheets.Add after:=Worksheets(Worksheets.Count)
Next
OrgWorkBook.Activate
i = 1
For Each Ws In Worksheets
Ws.Cells.Copy Destination:=NewWorkBook.Sheets(i).Range("A1")
i = i + 1
Next
NewWorkBook.Activate
ActiveWorkbook.Close True, fname
ChDir Application.DefaultFilePath

回答No.2

pkh4989

すみません。
以下の変えてください。
　　Const wDir As String = "C:\Documents and Settings\たかじん\デスクトップ"

回答No.1

pkh4989

こんにちは。

少し、マクロを変えてみました。要望通りに動くか分かりませんが、お試しください。

Option Explicit
Sub シート複写()
　　Dim SheetCount　As Integer
　　Dim i　　　　　 As Integer
　　Dim fname　　　 As String
　　Dim Ws　　　　　As Worksheet
　　Dim OrgWorkBook As Workbook　　　　 '元ブック用
　　Dim NewWorkBook As Workbook　　　　 '新しいブック用
　　Const wDir As String = "C:\Documents and Settings\parkkwanhoon\デスクトップ"
　　'
　　SheetCount = Worksheets.Count
　　ChDir wDir　　　　　　　　　　　　　'指定フォルダをActiveにする
　　fname = wDir & "\Book1"　　　　　　 '初期ファイル名を設定
　　'ファイル保存のフォームを表示する
　　fname = Application.GetSaveAsFilename(InitialFileName:=fname, _
　　　　　　　　　　　filefilter:="Excel ファイル (*.xls), *.xls", Title:="ファイル保存")
　　If fname = "False" Then Exit Sub　　'キャンセル時、終了
　　'
　　Set OrgWorkBook = ActiveWorkbook
　　Workbooks.Add (xlWBATWorksheet)　　 '新しいブックを生成
　　Set NewWorkBook = ActiveWorkbook
　　'元ブックのシート分、新しいブックにシートを追加
　　For i = 2 To SheetCount
　　　　Sheets.Add after:=Worksheets(Worksheets.Count)
　　Next
　　'
　　'元ブックのシート情報を新しいブックのシートへコピーする
　　i = 1
　　For Each Ws In OrgWorkBook.Worksheets
　　　　Ws.Cells.Copy Destination:=NewWorkBook.Sheets(i).Range("A1")
　　　　NewWorkBook.Sheets(i).Buttons.Delete　　　　'ボタン削除
　　　　i = i + 1
　　Next
　　NewWorkBook.Activate　　　　　　　　　　　　　　'新しいブックをActiveにする
　　'新しいブックを入力されたファイル名で保存する
　　ActiveWorkbook.SaveAs Filename:=fname
　　ActiveWorkbook.Close　　　　　　　　　　　　　　'新しいブックを閉じる
　　ChDir Application.DefaultFilePath
End Sub