Excel - VBA：複数の動的な名前付き範囲をpowerpointの新しいインスタンスに送信する方法

Question

本当に誰かが私を助けてくれることを願っています。私はVBAで「そんなに」そうだが、ここで何か助けを必要としている。

私はインターネットを拡大していくつかの例を見つけましたが、自分のニーズを満たすためにそれらを調整するのに十分ではないので、誰かが私を助けてくれることを本当に望んでいましたか？

定期的に更新されるレポートがあります。このレポートには、ピボットスライサーなどで基準が変更されるたびに動的に更新される名前の範囲があります。

以下のコードでは、名前付き範囲の1つを取得し、それを新しいpowerpointのインスタンスにコピーします：https://www.thespreadsheetguru.com/blog/2014/3/17/copy-paste-an-excel-range-into-powerpoint-with-vba）。

ただし、名前付き範囲の配列をコピーして、同じスライド上のPowerPointの同じインスタンスに貼り付けるには、これを変更する必要があります。名前付き範囲は「Top5Risks」、「ActionsCompleted」、および「UpcomingActions」です。

貼り付け時にPowerPoint内でこれらの位置をそれぞれどのように設定できるかをアドバイスできれば、本当にうれしいでしょう。つまり、重ねて表示されるのではなく、左上に1つ、右上に1つ、もう1つはたとえば左下です。ここに私が今まで持っているコードはあります：

Sub ExcelRangeToPowerPoint() 

Dim rng As Range 
Dim PowerPointApp As Object 
Dim myPresentation As Object 
Dim mySlide As Object 
Dim myShape As Object 

'One named range 
Set rng = Worksheets("FX KPI Dashboard").Range("UpcomingActions") 

'Create an Instance of PowerPoint 
On Error Resume Next 

'Is PowerPoint already opened? 
    Set PowerPointApp = GetObject(class:="PowerPoint.Application") 

'Clear the error between errors 
    Err.Clear 

'If PowerPoint is not already open then open PowerPoint 
    If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application") 

'Handle if the PowerPoint Application is not found 
    If Err.Number = 429 Then 
    MsgBox "PowerPoint could not be found, aborting." 
    Exit Sub 
    End If 

On Error GoTo 0 

'Optimize Code 
Application.ScreenUpdating = False 

'Create a New Presentation 
Set myPresentation = PowerPointApp.Presentations.Add 


'Add a slide to the Presentation 
Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly 

'Copy Excel Range 
rng.Copy 

'Paste to PowerPoint and position 
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile 
Set myShape = mySlide.Shapes(mySlide.Shapes.Count) 

'Set position: 
    myShape.Left = 66 
    myShape.Top = 152 

'Make PowerPoint Visible and Active 
PowerPointApp.Visible = True 
PowerPointApp.Activate 

'Clear The Clipboard 
Application.CutCopyMode = False 

End Sub 

あなたからのアドバイスは本当に感謝して非常に歓迎されます。私の正気はそれに依存します！ :)

おかげ

ショーン

P.S.私はMS Office 2013を実行しています

Answer 1

私はあなたのコードを最適化していません（これは非常に非効率的です）。とにかく、以下は現在動作します。

あなたがコピーしたい名前付き範囲の名前をn_rangesの配列に入れます。また、Excelで指定されたすべての範囲をループするカウンタと、すべての名前付き範囲（pos_hit）をループするときに名前付き範囲が発生するときにカウントするカウンタ（n_counter）も定義する必要があります。

他の名前のついた範囲（同じシート？）がどこにあるのかはっきりしていないので、同じActiveWorkbookにあると仮定しました。

形状を配置するために、シェイプの左と上部の属性（left_array、top_array）を格納する2つの配列を使用しました。ここでも、名前付き範囲の可能な形状/サイズが分からないため、これらの値で遊ぶ必要があります。コピーする名前付き範囲ごとに、各配列に1つのエントリが必要です。パワーポイントは単位として使用され、1インチあたり72ポイント（66ポイントはちょうど1インチ未満）です。これらは、新しい変数です：Activeworkbook内のすべての名前付き範囲を超える我々ループとして

Dim n_counter As Integer 
n_ranges = Array("Top5Risks", "ActionsCompleted", "UpcomingActions") 

left_array = Array(66, 66, 516) 
top_array = Array(152, 352, 152) 

、我々はあなたがパワーポイントにコピーする名前付き範囲を発見したかどうかを判断する方法が必要です。この小さなユーティリティ関数を含めることでこれを行います。あなたのモジュールに貼り付けてください。これは、追加のユーティリティ関数です：

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean 
    IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1) 
End Function 

あなたは、私たちはループの外に力点インスタンスを作成するコード（スライド）を移動する必要がありますが、同じパワーポイントの同じスライド上の図形を望んでいたと言ったので（そうしないと、複数のインスタンスが作成されます）。 （下部にIsInArrayと）一緒にすべてを置く

は

あなたが得る：

Sub ExcelRangeToPowerPoint() 

Dim rng As Range 
Dim PowerPointApp As Object 
Dim myPresentation As Object 
Dim mySlide As Object 
Dim myShape As Object 

Dim n_counter As Integer 
Dim pos_hit As Integer 

pos_hit = 0 
n_ranges = Array("Top5Risks", "ActionsCompleted", "UpcomingActions") 

left_array = Array(66, 66, 516) 
top_array = Array(152, 352, 152) 

'Create an Instance of PowerPoint 
On Error Resume Next 

'Is PowerPoint already opened? 
    Set PowerPointApp = GetObject(class:="PowerPoint.Application") 

'Clear the error between errors 
    Err.Clear 

'If PowerPoint is not already open then open PowerPoint 
    If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application") 

'Handle if the PowerPoint Application is not found 
    If Err.Number = 429 Then 
    MsgBox "PowerPoint could not be found, aborting." 
    Exit Sub 
    End If 

On Error GoTo 0 

Set myPresentation = PowerPointApp.Presentations.Add 
Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly 

'One named range 
For n_counter = 1 To ActiveWorkbook.Names.Count 

    If IsInArray(ActiveWorkbook.Names(n_counter).Name, n_ranges) Then 
     Set rng = Range(ActiveWorkbook.Names(n_counter).Name) 
     rng.Copy 

     mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile 
     Set myShape = mySlide.Shapes(mySlide.Shapes.Count) 

     myShape.Left = left_array(pos_hit) 
     myShape.Top = top_array(pos_hit) 

     pos_hit = pos_hit + 1 
     Application.CutCopyMode = False 
    End If 

Next 

PowerPointApp.Visible = True 
PowerPointApp.Activate 

End Sub 

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean 
    IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1) 
End Function