HOME > Q&A > Excel （VBA）

Excel （VBA）
Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10全般 : Microsoft 365)
エクセルのセル範囲をパワポに貼り付けたときの解像度が足りない
投稿日時: 22/06/12 16:21:11
投稿者: ip8bk

いつもお世話になっております。
下記のコードを使い、エクセルのセル範囲をコピーし、形式を選択してパワーポイントに貼り付けています。
パワポに貼り付けられた画像が荒いため、解像度を上げることを検討しております。Shapes.PasteSpecial methodの公式ドキュメントから形式をBitmapを選択していますが、さらに解像度を上げるにはどうしたらよいでしょうか？
 
公式ドキュメント：
https://docs.microsoft.com/ja-jp/office/vba/api/powerpoint.shapes.pastespecial
 

Option Explicit

Sub test11()

    Dim PP  As PowerPoint.Application
    Dim prs As PowerPoint.Presentation
    Dim sld As PowerPoint.Slide
    Dim shp As PowerPoint.Shape

    Dim FSO As Scripting.FileSystemObject
    Dim Fil As Scripting.File
    Dim rng As Variant
    Set PP = CreateObject("PowerPoint.Application")
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set prs = PP.Presentations.Add
    Set rng = Range("a1:ad30")
    rng.Copy
    Set sld = prs.Slides.Add(prs.Slides.Count + 1, ppLayoutBlank)
    With sld
        .FollowMasterBackground = msoFalse
        With .Background.Fill
            .TwoColorGradient Style:=msoGradientHorizontal, variant:=2
            .ForeColor.RGB = RGB(255, 255, 255)
            .BackColor.RGB = RGB(204, 255, 255)
        End With
    End With
    prs.PageSetup.SlideWidth = 500
    prs.PageSetup.SlideHeight = 500
    sld.Select
    sld.Shapes.PasteSpecial DataType:=ppPasteBitmap, link:=msoFalse
    Set shp = sld.Shapes(1)
    With shp
        .LockAspectRatio = True '縦横比を固定

        '挿入した画像をスライドのサイズに合わせる
        If .Width > .Height Then
            .Width = prs.PageSetup.SlideWidth
        Else
            .Height = prs.PageSetup.SlideHeight
        End If
            .Select
    End With

    '画像をスライド中央に配置
    With PP.ActiveWindow.Selection.ShapeRange
        .Align msoAlignCenters, True
        .Align msoAlignMiddles, True
    End With

    With sld.SlideShowTransition
        .AdvanceOnClick = msoTrue
        .AdvanceOnTime = msoTrue
        .AdvanceTime = 0.1
    End With

End Sub
回答
投稿日時: 22/06/12 22:59:55
投稿者: MMYS

VBAコード以前に、ご希望の動作が、手作業で確認済みですか。
 
形式を選択して貼り付け
https://support.microsoft.com/ja-jp/office/%E5%BD%A2%E5%BC%8F%E3%82%92%E9%81%B8%E6%8A%9E%E3%81%97%E3%81%A6%E8%B2%BC%E3%82%8A%E4%BB%98%E3%81%91-e03db6c7-8295-4529-957d-16ac8a778719
 
【PowerPoint】スライドにExcelの表を貼り付けるには？
https://enterprisezine.jp/iti/detail/628#
 
回答
投稿日時: 22/06/13 11:53:15
投稿者: Suzu

既に MMYS さん からも在りますが
 
目的の動作をさせるために、テスト中であり、そのコードを抜き取り提示されているのは理解できるのですが、
関係無い部分が原因の可能性を否定する為にも
 
単体の動作を 手動で 確認し、それを VBAで実行。そこから組み合わせましょう。
 
BMPの解像度が問題なのではなく、PowerPoint 上に張り付けた Shape の 倍率を確認ください。
100% ではないですよね？
100以外の場合、すごく粗い ビットとして表示される事があります。
 
100% になる様に コピー元のサイズを変更するなりしましょう。
 
 
 
-----------------------------------------------------------------------------------------
元々 グラフをパラパラとスライドショーとして流したい だったと記憶しています。
png で保存する部分は Excel で出来ており
 
との事でしたので、
 
当方より、画像ファイルを 特定フォルダから PoerPoint に貼り付け
スライドショーとして MP4 で保存する例を提示しました。
 
そこから セルにグラデーション背景の話、セルを Chart に貼り付け 等の質問があり
現在に至っています。
 
先に提示したコードをベースにしている部分があり 不要であると思える コードもありそうです。
前提が変わっている部分もありそうですがいかがでしょう？
 
 
そもそも、Excelで行なおうとするのが 疑問でしたが、

引用:
2~3枚の組み合わせで1000以上作成したかった

との事でしたが、コードを作成している時間を考えると、地道の方が早かったのでは とも思います
画像ソフトであれば、グラデーションも背景レイヤ につけ、その中央等に本来の画像を重ねれば良い話。
 
やりたい素工程 は何なのか、それを効率化する為にどんな事が自動化できそうか？
その為にどんなソフトを使うか 全体観を含め、検討してはどうかと思います。
投稿日時: 22/06/13 12:39:52
投稿者: ip8bk

ご回答ありがとうございます。
胸に突き刺さる回答がございましたが、メリットとデメリットを考えた結果、まだコードを書き続けることにしています。
説明不足で申し訳ございませんが、下記のコードでアニメーションGIFで部分的にRectangularGradientで動きを出していますが、動いていない外周の部分の揺らぎが気になるので、少しでも抑えたいということです。
RectangularGradientがないと起こらない現象のため、手作業での操作と比較できておりません。
 

引用:
BMPの解像度が問題なのではなく、PowerPoint 上に張り付けた Shape の 倍率を確認ください。
100% ではないですよね？
100以外の場合、すごく粗い ビットとして表示される事があります。
  
100% になる様に コピー元のサイズを変更するなりしましょう。

 
下記のコードで元サイズを調整するようにしました。
なのでサイズを合わせるコードは最終的に削除する予定です。
 
Dim rng As Excel.Range, rg As Range
Set rng = Range("a1:ad30")
Dim a As Range
For Each a In rng.Columns
    With a
        .ColumnWidth = 5
        .RowHeight = .Width
    End With
Next

 
まだ外周の揺らぎが気になりますので、何かご教示いただけることがございましたら、よろしくお願い致します。
 
Option Explicit

Sub test11()

    Application.ScreenUpdating = False
    ActiveWindow.DisplayGridlines = False

    Dim PP  As PowerPoint.Application
    Dim prs As PowerPoint.Presentation
    Dim sld As PowerPoint.Slide
    Dim shp As PowerPoint.Shape

    Dim FSO As Scripting.FileSystemObject
    Dim Fil As Scripting.File
    Dim rng As Excel.Range, rg As Range
    Set rng = Range("a1:ad30")
    Set rg = Range("h8:x22")
    Dim a As Range
    For Each a In rng.Columns
        With a
            .ColumnWidth = 5
            .RowHeight = .Width
        End With
    Next
    
    Set PP = CreateObject("PowerPoint.Application")
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set prs = PP.Presentations.Add

    Dim rgrd As Excel.RectangularGradient
    Dim cs As Excel.ColorStop
    
    PP.ActiveWindow.WindowState = 2
    
    Dim bkr As Integer, bkg As Integer, bkb As Integer
    bkr = Range("hr" & Range("hw89") + 89).Value
    bkg = Range("hs" & Range("hw89") + 89).Value
    bkb = Range("ht" & Range("hw89") + 89).Value
    
    Dim i As Integer
    For i = 1 To 2

        '塗りつぶしの設定
        With rg.Interior
            '塗りつぶしのパターンを矩形グラデーションに
            .Pattern = xlPatternRectangularGradient
            '矩形グラデーションの場合、Gradient プロパティは
            Set rgrd = .Gradient
        End With

'        矩形グラデーションの設定
        With rgrd
            'グラデーションの収束先となるポイント/ベクトルの指定
            If i Mod 2 = 0 Then
                .RectangleTop = 0.75
                .RectangleLeft = 0.75
                .RectangleRight = 0.75
                .RectangleBottom = 0.75
            Else
                .RectangleTop = 0.25
                .RectangleLeft = 0.25
                .RectangleRight = 0.25
                .RectangleBottom = 0.25
            End If
            '全てのカラーストップポイントをクリア
            .ColorStops.Clear

            '0%の位置にカラーストップポイントを追加
            Set cs = .ColorStops.Add(0)
            cs.Color = RGB(240, 240, 170)
            Set cs = Nothing

            '20%の位置にカラーストップポイントを追加
            Set cs = .ColorStops.Add(0.2)
            cs.Color = RGB(195, 180, 100)
            Set cs = Nothing

            '100%の位置にカラーストップポイントを追加
            Set cs = .ColorStops.Add(1)
            cs.Color = RGB(150, 120, 30)
            Set cs = Nothing
        End With
        Set rgrd = Nothing
        Application.ScreenUpdating = True
        Application.Wait [Now() + "00:00:00.2"]
        With Worksheets("Sheet1")
            rng.Copy
            Dim ws As Worksheet
            Set ws = ThisWorkbook.Worksheets("sheet1")
            Set sld = prs.Slides.Add(prs.Slides.Count + 1, ppLayoutBlank)
            Application.ActiveWindow.WindowState = ppWindowMinimized
            prs.PageSetup.SlideWidth = 1350
            prs.PageSetup.SlideHeight = 1350
            sld.Select
            sld.Shapes.PasteSpecial DataType:=ppPasteBitmap, link:=msoFalse
            Set shp = sld.Shapes(1)
            With shp
                .LockAspectRatio = True '縦横比を固定

                '挿入した画像をスライドのサイズに合わせる
                If .Width > .Height Then
                    .Width = prs.PageSetup.SlideWidth
                Else
                    .Height = prs.PageSetup.SlideHeight
                End If
                    .Select
            End With

            '画像をスライド中央に配置
            With PP.ActiveWindow.Selection.ShapeRange
                .Align msoAlignCenters, True
                .Align msoAlignMiddles, True
            End With
        End With

        With sld.SlideShowTransition
            .AdvanceOnClick = msoTrue
            .AdvanceOnTime = msoTrue
            .AdvanceTime = 0.1
        End With
    Next i
    Dim WSH As Object
    Set WSH = CreateObject("WScript.Shell")
    Dim outputPath As String
    outputPath = WSH.SpecialFolders("MyDocuments") & "\2022png" & "\anime"
    Dim lastrow As Integer
    lastrow = WorksheetFunction.CountA(Worksheets("sheet2").Columns(1)) + 1
    Worksheets("sheet2").Cells(lastrow, 1) = 1
    Dim file_name As String
    file_name = "anime#" & lastrow & ".gif"
    outputPath = outputPath & "\" & file_name
    Set WSH = Nothing
    Application.Wait (Now + TimeValue("00:00:10"))  '10秒待機
    prs.SaveAs Filename:=outputPath, FileFormat:=40
    PP.Activate
    PP.ActiveWindow.WindowState = 2
    On Error Resume Next
    Do While PP.Presentations.Count > 0
        Application.Wait (Now + TimeValue("00:00:3"))  '10秒待機
        prs.Saved = False
        prs.Close
    Loop
    On Error GoTo 0

    PP.Quit
    Set shp = Nothing
    Set sld = Nothing
    Set prs = Nothing
    Set PP = Nothing
    Set Fil = Nothing
    Set FSO = Nothing
    Set rg = Nothing
    
    ActiveWindow.DisplayGridlines = True
    Application.ScreenUpdating = True

End Sub
回答
投稿日時: 22/06/13 17:08:21
投稿者: Suzu

結局 解像度の話は解決したと言うことで良いのでしょうか？
 
 

引用:
動いていない外周の部分の揺らぎが気になるので、少しでも抑えたいということです。

 
手元 365 ではないので、MP4を作成し確認しましたが、
何を【ゆらぎ】と言っているのか 確認できませんでした。
 
 
引用:
RectangularGradientがないと起こらない現象のため、手作業での操作と比較できておりません。

 
PowerPointの段階でそのゆらぎが発生するのか
手動で各フォーマットの動画にした時にはどうなのか
カラーストップポイントを2つではなく、1つの時はどうなのか
Excel から 画像としてコピペするのではなく、PowerPoint側で Shapeとして作成たらどうなのか
 
確認できる事は沢山あります。
投稿日時: 22/06/14 07:32:29
投稿者: ip8bk

引用:
回答    
投稿日時: 22/06/13 17:08:21投稿者: Suzu
結局 解像度の話は解決したと言うことで良いのでしょうか？
  
  
引用:
動いていない外周の部分の揺らぎが気になるので、少しでも抑えたいということです。
 
  
手元 365 ではないので、MP4を作成し確認しましたが、
何を【ゆらぎ】と言っているのか 確認できませんでした。

 
ご回答ありがとうございます。
 
すみません、揺らぎという表現は正しくなかったです。私が揺らぎと言っていたのは、砂嵐のような粒粒が動いている状態のことです。再現性ありませんでしょうか？
 
よくわかっていませんが、解像度が低いことが原因で問題が起きていると考えています。
そのため、まだ解決できていません。
 
引用:
PowerPointの段階でそのゆらぎが発生するのか
手動で各フォーマットの動画にした時にはどうなのか
カラーストップポイントを2つではなく、1つの時はどうなのか
Excel から 画像としてコピペするのではなく、PowerPoint側で Shapeとして作成たらどうなのか
  
確認できる事は沢山あります。

 
説明不足で申し訳ありません。パワポの時点ではすごくきれいですが、アニメーションGIFにすると荒さが目立つように見えます。なので、パワポから変換するときの問題と思っています。コードを途中でストップして手作業で保存しても同様の問題が起きます。
 
また、下記のコードでは問題は起きません。
 
Option Explicit

Sub test11()

    Application.ScreenUpdating = False
    ActiveWindow.DisplayGridlines = False

    Dim PP  As PowerPoint.Application
    Dim prs As PowerPoint.Presentation
    Dim sld As PowerPoint.Slide
    Dim shp As PowerPoint.Shape

    Dim FSO As Scripting.FileSystemObject
    Dim Fil As Scripting.File
    Dim rng As Excel.Range, rg As Range
    Set rng = Range("a1:ad30")
    Set rg = Range("h8:x22")
    Dim a As Range
    For Each a In rng.Columns
        With a
            .ColumnWidth = 5
            .RowHeight = .Width
        End With
    Next
    
    Set PP = CreateObject("PowerPoint.Application")
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set prs = PP.Presentations.Add

    Dim rgrd As Excel.RectangularGradient
    Dim cs As Excel.ColorStop
    
    PP.ActiveWindow.WindowState = 2
    
    Dim bkr As Integer, bkg As Integer, bkb As Integer
    bkr = Range("hr" & Range("hw89") + 89).Value
    bkg = Range("hs" & Range("hw89") + 89).Value
    bkb = Range("ht" & Range("hw89") + 89).Value
    
    Dim i As Integer
    For i = 1 To 2

        '塗りつぶしの設定
        With rg.Interior
            '塗りつぶしのパターンを矩形グラデーションに
            .Pattern = xlPatternRectangularGradient
            '矩形グラデーションの場合、Gradient プロパティは
            Set rgrd = .Gradient
        End With

'        矩形グラデーションの設定
        With rgrd
            'グラデーションの収束先となるポイント/ベクトルの指定
'            If i Mod 2 = 0 Then
                .RectangleTop = 0.75
                .RectangleLeft = 0.75
                .RectangleRight = 0.75
                .RectangleBottom = 0.75
'            Else
'                .RectangleTop = 0.25
'                .RectangleLeft = 0.25
'                .RectangleRight = 0.25
'                .RectangleBottom = 0.25
'            End If
            '全てのカラーストップポイントをクリア
            .ColorStops.Clear

            '0%の位置にカラーストップポイントを追加
            Set cs = .ColorStops.Add(0)
            cs.Color = RGB(240, 240, 170)
            Set cs = Nothing

            '20%の位置にカラーストップポイントを追加
            Set cs = .ColorStops.Add(0.2)
            cs.Color = RGB(195, 180, 100)
            Set cs = Nothing

            '100%の位置にカラーストップポイントを追加
            Set cs = .ColorStops.Add(1)
            cs.Color = RGB(150, 120, 30)
            Set cs = Nothing
        End With
        Set rgrd = Nothing
        Application.ScreenUpdating = True
        Application.Wait [Now() + "00:00:00.2"]
        With Worksheets("Sheet1")
            rng.Copy
            Dim ws As Worksheet
            Set ws = ThisWorkbook.Worksheets("sheet1")
            Set sld = prs.Slides.Add(prs.Slides.Count + 1, ppLayoutBlank)
            Application.ActiveWindow.WindowState = ppWindowMinimized
            prs.PageSetup.SlideWidth = 1350
            prs.PageSetup.SlideHeight = 1350
            sld.Select
            sld.Shapes.PasteSpecial DataType:=ppPasteBitmap, link:=msoFalse
            Set shp = sld.Shapes(1)
            With shp
                .LockAspectRatio = True '縦横比を固定

                '挿入した画像をスライドのサイズに合わせる
                If .Width > .Height Then
                    .Width = prs.PageSetup.SlideWidth
                Else
                    .Height = prs.PageSetup.SlideHeight
                End If
                    .Select
            End With

            '画像をスライド中央に配置
            With PP.ActiveWindow.Selection.ShapeRange
                .Align msoAlignCenters, True
                .Align msoAlignMiddles, True
            End With
        End With

        With sld.SlideShowTransition
            .AdvanceOnClick = msoTrue
            .AdvanceOnTime = msoTrue
            .AdvanceTime = 0.1
        End With
    Next i
    Dim WSH As Object
    Set WSH = CreateObject("WScript.Shell")
    Dim outputPath As String
    outputPath = WSH.SpecialFolders("MyDocuments") & "\2022png" & "\anime"
    Dim lastrow As Integer
    lastrow = WorksheetFunction.CountA(Worksheets("sheet2").Columns(1)) + 1
    Worksheets("sheet2").Cells(lastrow, 1) = 1
    Dim file_name As String
    file_name = "anime#" & lastrow & ".gif"
    outputPath = outputPath & "\" & file_name
    Set WSH = Nothing
    Application.Wait (Now + TimeValue("00:00:10"))  '10秒待機
    prs.SaveAs Filename:=outputPath, FileFormat:=40
    PP.Activate
    PP.ActiveWindow.WindowState = 2
    On Error Resume Next
    Do While PP.Presentations.Count > 0
        Application.Wait (Now + TimeValue("00:00:3"))  '10秒待機
        prs.Saved = False
        prs.Close
    Loop
    On Error GoTo 0

    PP.Quit
    Set shp = Nothing
    Set sld = Nothing
    Set prs = Nothing
    Set PP = Nothing
    Set Fil = Nothing
    Set FSO = Nothing
    Set rg = Nothing
    
    ActiveWindow.DisplayGridlines = True
    Application.ScreenUpdating = True

End Sub

 
回答
投稿日時: 22/06/14 09:01:24
投稿者: Suzu

当方では、GIF作成できない環境です。MP4では再現できません。
再現できる方のコメントをお待ちください。
 
 
特定条件が”重なる”事で発生する事が多いので、原因を特定できなくとも、
回避する術がある事が多いです。
画像としているから、粗くなるのですから Shapeとすれば発生する事は無いと思います。
 
 
これだけは言っておきます。Excelで描写に過度な期待をしない事です。
何事も 向き・不向きはあるのですから。
回答
投稿日時: 22/06/14 10:45:44
投稿者: sk

引用:
パワポに貼り付けられた画像が荒い

引用:
私が揺らぎと言っていたのは、砂嵐のような粒粒が動いている状態のことです。

引用:
パワポの時点ではすごくきれいですが、アニメーションGIFにすると荒さが目立つように見えます。

GIF フォーマットで保存しようとしている限りは無理ではないでしょうか。
 
GIF フォーマットの特性上、特に高解像度の写真やグラデーションを扱う
画像ではどうしても減色処理が発生し、大抵の場合画質は低下しますので。
投稿日時: 22/06/20 07:05:18
投稿者: ip8bk

ご回答いただきました皆様ありがとうございました。
VBAでは解像度の問題を解決することが難しいことがわかりましたので、アニメGIF専用アプリを使うことにしました。