[[20140826125743]]　『画像のサイズを指定したい。』（ふみ）　ページの最後に飛ぶ

『画像のサイズを指定したい。』（ふみ）

こんにちは。
シート「産出金額」にある表を１つ、シート「優先」にある表を１つ、
シート「負荷状況」にある表を２つ、合計４つの表を図としてコピーして
シート「印刷」に貼り付けています。

下記のコードはマクロで記録した後、ちょこちょこいじっていますが、
一応４つの表をシート「印刷」に貼り付けて一枚のA4サイズで印刷する事が
出来ています。貼り付ける位置はセルで指定しています。

ただ、表の大きさを指定する方法が解らない為、A4サイズに対して小さめで、
見にくくなってしまっています。

この４つの図の大きさを指定する方法はないでしょうか？
よろしくお願いします。

Sub 印刷()

 Application.ScreenUpdating = False                                 '画面更新禁止

Sheets("印刷").Select
Cells.ClearContents

Dim ob As Shape
With ActiveSheet

For Each ob In .Shapes
If Not Intersect(ob.TopLeftCell, .Range("A1:BZ200")) Is Nothing Then
ob.Delete
End If
Next

End With

 Sheets("産出金額").Select
    Range("A1:R45").Select
    Selection.Copy

    Sheets("印刷").Select
    Range("C1").Select

    ActiveSheet.Pictures.Paste(link:=False).Select

    Application.CutCopyMode = False

    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(0)
        .BottomMargin = Application.InchesToPoints(0)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With

    Sheets("優先").Select
    Range("A1:AE39").Select
    Selection.Copy
    Range("A1").Select
    Sheets("印刷").Select
    Range("C60").Select

    ActiveSheet.Pictures.Paste(link:=False).Select

    Application.CutCopyMode = False

    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(0)
        .BottomMargin = Application.InchesToPoints(0)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With

    Sheets("負荷状況").Select
    Range("A1:R52").Select
    Selection.Copy

    Sheets("印刷").Select
    Range("Z1").Select

     ActiveSheet.Pictures.Paste(link:=False).Select

     Application.CutCopyMode = False

    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(0)
        .BottomMargin = Application.InchesToPoints(0)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With

    Sheets("負荷状況").Select
    Range("A56:R100").Select
    Selection.Copy
    Range("A1").Select
    Sheets("印刷").Select
    Range("Z60").Select

     ActiveSheet.Pictures.Paste(link:=False).Select

     Application.CutCopyMode = False

    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(0)
        .BottomMargin = Application.InchesToPoints(0)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With

    Sheets("産出金額").Select
    Range("A1").Select

    Sheets("印刷").Select
    ActiveWindow.SelectedSheets.PrintPreview

 Application.ScreenUpdating = True                                          '画面更新許可

End Sub

＜使用 Excel：Excel2007、使用 OS：Windows7 ＞

 流石にこれは読む気にならないと思いますよ・・・
 ページセットアップだけは何をどうしたいのか分からないのでそのままコピーしましたが、
 それ以外はまとめられます。

    Sub 印刷()
        Application.ScreenUpdating = False                                 '画面更新禁止
        Cells.ClearContents
        Dim ob As Shape
        Dim WS As Worksheet
        Set WS = Sheets("印刷")
        With WS
            For Each ob In .Shapes
                If Not Intersect(ob.TopLeftCell, .Range("A1:BZ200")) Is Nothing Then
                    ob.Delete
                End If
            Next
        End With
        図の貼り付け Sheets("産出金額").Range("A1:R45"), WS.Range("C1"), 50
        図の貼り付け Sheets("優先").Range("A1:AE39"), WS.Range("C60"), 50
        図の貼り付け Sheets("負荷状況").Range("A1:R52"), WS.Range("Z1"), 50
        図の貼り付け Sheets("負荷状況").Range("A56:R100"), WS.Range("Z60"), 50
        Call 頁セットアップ(WS)
        WS.PrintPreview
        Application.ScreenUpdating = True                                          '画面更新許可
    End Sub
    Private Function 図の貼り付け(コピー元 As Range, コピー先 As Range, 割合 As Long)
        コピー元.CopyPicture , Appearance:=xlPrinter
        コピー先.Select
        With ActiveSheet.Pictures.Paste
            .Height = .Height * (割合 / 100)
            .Width = .Width * (割合 / 100)
        End With
    End Function
    Private Sub 頁セットアップ(WS As Worksheet)
        With WS.PageSetup
            .LeftHeader = ""
            .CenterHeader = ""
            .RightHeader = ""
            .LeftFooter = ""
            .CenterFooter = ""
            .RightFooter = ""
            .LeftMargin = Application.InchesToPoints(0)
            .RightMargin = Application.InchesToPoints(0)
            .TopMargin = Application.InchesToPoints(0)
            .BottomMargin = Application.InchesToPoints(0)
            .HeaderMargin = Application.InchesToPoints(0)
            .FooterMargin = Application.InchesToPoints(0)
            .PrintHeadings = False
            .PrintGridlines = False
            .PrintComments = xlPrintNoComments
            .PrintQuality = 600
            .CenterHorizontally = False
            .CenterVertically = False
            .Orientation = xlLandscape
            .Draft = False
            .PaperSize = xlPaperA4
            .FirstPageNumber = xlAutomatic
            .Order = xlDownThenOver
            .BlackAndWhite = False
            .Zoom = False
            .FitToPagesWide = 1
            .FitToPagesTall = 1
            .PrintErrors = xlPrintErrorsDisplayed
            .OddAndEvenPagesHeaderFooter = False
            .DifferentFirstPageHeaderFooter = False
            .ScaleWithDocHeaderFooter = True
            .AlignMarginsHeaderFooter = True
            .EvenPage.LeftHeader.Text = ""
            .EvenPage.CenterHeader.Text = ""
            .EvenPage.RightHeader.Text = ""
            .EvenPage.LeftFooter.Text = ""
            .EvenPage.CenterFooter.Text = ""
            .EvenPage.RightFooter.Text = ""
            .FirstPage.LeftHeader.Text = ""
            .FirstPage.CenterHeader.Text = ""
            .FirstPage.RightHeader.Text = ""
            .FirstPage.LeftFooter.Text = ""
            .FirstPage.CenterFooter.Text = ""
            .FirstPage.RightFooter.Text = ""
        End With
    End Sub

（稲葉） 2014/08/26(火) 16:38

稲葉さん、ありがとう御座います。
いつもの通り、めちゃくちゃなコードですみません。

今日はバタバタしているので、明日頂いたコードを
走らせてみます。サイズ変更出来るのが楽しみです。
ありがとう御座います。
（ふみ） 2014/08/26(火) 16:48

稲葉さん、おはよう御座います。

頂いたコードを走らせてみましたが、
コピー先.Selectのところで、RangeクラスのSelectメソッドが失敗しました、のエラーになります。
Private Function 図の貼り付け　が Sub 印刷()　にどう関わっているのか理解出来ない為、
修正の仕方が解りません。

またサイズ変更はどこで行なうのですか？
図の貼り付け　の50を変更？
それとも .Height = .Height * (割合 / 100)の割合に数値記入？
情けない質問で申し訳ありませんが御教示下さい。

よろしくお願いします。

（ふみ） 2014/08/27(水) 08:36

稲葉さん、追加で申し訳有りません。

とりあえずエラー回避の為にコピー先.SelectをSheets("印刷").Selectに変えて
走らせました。

割合の数値を変えて最適なサイズの割合を確定させたかったのですが、
数値を変えていくと、エクセルが勝手に元のサイズを変えてしまう様で、
割合の数値通りにサイズが変わりません。
昨日、自分で作ったコードも元のサイズに対して、というコードだったのですが、
同じ現象でした。
元のサイズに対して、ではなく、サイズを数値指定する様に出来ないでしょうか？
よろしくお願いします。

（ふみ） 2014/08/27(水) 09:05

ちょっと説明します。

 Private Function 図の貼り付け(コピー元 As Range, コピー先 As Range, 割合 As Long)
は
図の貼り付け Sheets("産出金額").Range("A1:R45"), WS.Range("C1"), 50
のデータを入れます。
つまり
コピー元 As Range は Sheets("産出金額").Range("A1:R45")
コピー先 As Range　は WS.Range("C1")
割合 As Long は 50
をそれぞれ見ています。
割合の部分の50を変えればサイズが変わります。
コピー先.Selectのところで、RangeクラスのSelectメソッドが失敗しました、のエラーになります。 
はSheets印刷で実行することでエラーが出ないです。
なおSheets("印刷").Select
だと同じ場所にコピーしてしますのでデータが重複してしまいます。

（デイト） 2014/08/27(水) 09:38

デイトさん、ありがとう御座います。

理解出来ました。コピー先.Selectの前にSheets("印刷").Selectを入れる事で
エラーは無くなりました。

ただ、50をいろいろ変更すると、やはり勝手にエクセルが元のサイズを変えてしまいます。
今、下記のコードを追加して、１つ目の図のサイズを指定する様にトライ中です。

 Dim g0 As Long
    Dim pic As Shape
    g0 = 1
    On Error Resume Next
    For Each pic In Sheets("印刷").Shapes
       If pic.Type = msoPicture Then
          pic.Name = "pic" & g0
          g0 = g0 + 1
          End If
    Next
    On Error GoTo 0

    Dim currHeight As Variant
    Dim currWidth As Variant

    ' 図形の現在の縦横の長さを取得する
    With Sheets("印刷").Shapes("pic1")
         currWidth = .Width
         currHeight = .Height
    End With

    MsgBox currWidth
    MsgBox currHeight

    ' 図形の現在の縦横の長さを指定
    With Sheets("印刷").Shapes("pic1")
         .Width = 1785
         .Height = 1207.5
    End With

元のサイズの数値を確認してから変更後のサイズをいろいろ指定していますが、
うまくいきそうなので続けてみます。

ありがとう御座いました。

（ふみ） 2014/08/27(水) 10:27

 体調不良で寝込んでます

 デイトさんフォローありがとうございます
 直接サイズ指定したいのでしたら、functionに新しい
 引数を追加して、縦横のサイズを渡した方がかんたんだ
 とおもいます
 ふみさんがやろうとしているやり方では、シェイプの
 名前が毎回変わってしまうので、意図したサイズにする
 には、はりつけの段階で名前をつける必要があります

 ですので、貼り付け時にサイズ指定する方法をお勧めします

 元のサイズを残して、元のサイズの何割にするか指定できるプロパティがあったと思いますので、調べてみてください
 ただ、貼り付けた図に対して使えたかは覚えてないので、できなかったらご免なさい

（稲葉） 2014/08/27(水) 14:19

稲葉さん、体調不良なのにありがとう御座います。

４つの図に対して繰り返しのコードを書いてみましたが、
ある程度、図を大きくしていくと、やはりエクセルが自動で調整してしまいます。

稲葉さんのアドバイスに基づいて、他の方法を調べてみます。

ゆっくり休んで下さい。お大事に。

（ふみ） 2014/08/27(水) 15:19

コメント返信：

[ 一覧(最新更新順) ]

[[20140826125743]] 『画像のサイズを指定したい。』（ふみ） ページの最後に飛ぶ

[[20140826125743]]　『画像のサイズを指定したい。』（ふみ）　ページの最後に飛ぶ