Excel (VBA)

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

 
(Windows 7 Professional : Excel 2010)
パワポのシート情報をエクセルへ転記する方法
投稿日時: 19/10/23 16:31:56
投稿者: bunbun99

大変困っております。
どなたか教えていただけると大変ありがたいです。
 
<やりたいこと>
 1.フォルダ内に300件のパワポファイルを保存。
 2.パワポファイルの2ページ目に、
  情報(チーム名、リーダ名、ファイル名)が記載してあるので、エクセルへ転記する。
 
フローは、下記の流れです。
 
 300件のパワポデータを1つのフォルダにまとめる
 ↓
 フォルダを選択
 ↓
 パワポ2ページ目の情報をエクセルへ転記する
 
近い作業はこちらのサイトにありますが、ただしEXCEL版なので、
パワーポイントでやりたいです。
 
  複数のExcelブックから必要な項目をコピーして1つのシートにまとめるVBA
  https://infith.com/system/excel/loop_find_list/

回答
投稿日時: 19/10/23 17:00:40
投稿者: sk

引用:
1.フォルダ内に300件のパワポファイルを保存。
2.パワポファイルの2ページ目に、
 情報(チーム名、リーダ名、ファイル名)が記載してあるので、
 エクセルへ転記する。

それらの各項目は具体的にスライド 2 のどこに
どのような形で記載されているのでしょうか。
 
・スライド 2 には 3 つのテキストボックスが存在する
 
・スライド 2 のいずれかのプレースホルダーにおいて
 3 つの項目が箇条書きにされている
 
・上記以外。

投稿日時: 19/10/23 17:13:58
投稿者: bunbun99

sk さんの引用:
引用:
1.フォルダ内に300件のパワポファイルを保存。
2.パワポファイルの2ページ目に、
 情報(チーム名、リーダ名、ファイル名)が記載してあるので、
 エクセルへ転記する。

それらの各項目は具体的にスライド 2 のどこに
どのような形で記載されているのでしょうか。
 
・スライド 2 には 3 つのテキストボックスが存在する
 
・スライド 2 のいずれかのプレースホルダーにおいて
 3 つの項目が箇条書きにされている
 
・上記以外。

ご質問ありがとうございます。「上記以外」です。
メニューの「挿入→表」から作成した表に、下記のように書いてあります。
  チーム名:●●
 リーダ名:△△

回答
投稿日時: 19/10/23 17:53:48
投稿者: sk

引用:
情報(チーム名、リーダ名、ファイル名

引用:
メニューの「挿入→表」から作成した表に、下記のように書いてあります。
  チーム名:●●
 リーダ名:△△

表の 1 行目の 2 列目のセルに[チーム名]、
2 行目の 2 列目のセルに[リーダ名]、
3 行目の 2 列目のセルに[ファイル名]が
それぞれ記載されている、ということでしょうか。
 
それとも、ここでの[ファイル名]とは
「そのプレゼンテーションファイル( ppt / pptx ファイル)自身の
名前(またはフルパス)」であり、(表に記載のない)それを取得して
ワークシート上に出力したい、ということでしょうか。

投稿日時: 19/10/23 23:12:25
投稿者: bunbun99

sk さんの引用:
引用:
情報(チーム名、リーダ名、ファイル名

引用:
メニューの「挿入→表」から作成した表に、下記のように書いてあります。
  チーム名:●●
 リーダ名:△△

表の 1 行目の 2 列目のセルに[チーム名]、
2 行目の 2 列目のセルに[リーダ名]、
3 行目の 2 列目のセルに[ファイル名]が
それぞれ記載されている、ということでしょうか。
 
それとも、ここでの[ファイル名]とは
「そのプレゼンテーションファイル( ppt / pptx ファイル)自身の
名前(またはフルパス)」であり、(表に記載のない)それを取得して
ワークシート上に出力したい、ということでしょうか。

説明がヘタで申し訳ありません。。。
 
パワーポイントの表は、
 1 行目の 2 列目のセルに[チーム名]、
 2 行目の 2 列目のセルに[リーダ名]、です。
 (ファイル名は記載されてないです)
 
引用:
それとも、ここでの[ファイル名]とは
「そのプレゼンテーションファイル( ppt / pptx ファイル)自身の
名前(またはフルパス)」であり、(表に記載のない)それを取得して
ワークシート上に出力したい、ということでしょうか。

ファイル名については、↑のとおりです!!

回答
投稿日時: 19/10/24 10:11:45
投稿者: sk

引用:
フローは、下記の流れです。
  
 300件のパワポデータを1つのフォルダにまとめる
 ↓
 フォルダを選択
 ↓
 パワポ2ページ目の情報をエクセルへ転記する

引用:
パワーポイントの表は、
 1 行目の 2 列目のセルに[チーム名]、
 2 行目の 2 列目のセルに[リーダ名]、です。
 (ファイル名は記載されてないです)

引用:
ここでの[ファイル名]とは
「そのプレゼンテーションファイル( ppt / pptx ファイル)自身の
名前(またはフルパス)」
であり、(表に記載のない)それを取得して
ワークシート上に出力したい

(標準モジュール)
----------------------------------------------------------------
Sub GetTeamsListFromPresentations()
         
    Dim xlsWorkbook As Excel.Workbook
    Dim xlsWorksheet As Excel.Worksheet
     
    Dim pptApp As Object 'PowerPoint.Application
    Dim pptPresentation As Object 'PowerPoint.Presentation
    Dim pptSlide As Object 'PowerPoint.Slide
    Dim pptShape As Object 'PowerPoint.Shape
    Dim pptTable As Object 'PowerPoint.Table
         
    Dim strFolderPath As String
    Dim strPresentationName As String
     
    Dim blnHasData As Boolean
    Dim lngRow As Long
    Dim strFullPath As String
    Dim strTeam As String
    Dim strLeader As String
     
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Powerpoint プレゼンテーションのあるフォルダを選択"
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count = 0 Then
            Exit Sub
        End If
        strFolderPath = .SelectedItems(1) & "\"
    End With
     
    strPresentationName = Dir(strFolderPath & "*.ppt")
     
    If strPresentationName = "" Then
        MsgBox "'" & strFolderPath & "' には Powerpoint プレゼンテーションが 1 つもありません。", _
               vbExclamation, _
               "該当ファイルなし"
        Exit Sub
    End If
     
    Set xlsWorkbook = Workbooks.Add
    Set xlsWorksheet = xlsWorkbook.Worksheets(1)
    lngRow = 1
     
    With xlsWorksheet
        .Name = "チームリスト"
        .Cells(lngRow, 1).Value = "ファイル名"
        .Cells(lngRow, 2).Value = "チーム名"
        .Cells(lngRow, 3).Value = "リーダ名"
        .Cells(lngRow, 4).Value = "備考"
    End With
     
    Set pptApp = CreateObject("PowerPoint.Application")
    pptApp.Visible = True
     
    Do Until strPresentationName = ""
         
        blnHasData = False
        strFullPath = strFolderPath & strPresentationName
        strTeam = ""
        strLeader = ""
             
        Set pptPresentation = pptApp.Presentations.Open(strFullPath, True)
        Set pptSlide = pptPresentation.Slides(2)
        For Each pptShape In pptSlide.Shapes
            If pptShape.HasTable Then
                Set pptTable = pptShape.Table
                With pptTable
                    If (.Rows.Count = 2) And (.Columns.Count = 2) And _
                       (.Cell(1, 1).Shape.TextFrame2.TextRange.Text Like "チーム*") And _
                       (.Cell(2, 1).Shape.TextFrame2.TextRange.Text Like "リーダ*") Then
                        blnHasData = True
                        strTeam = .Cell(1, 2).Shape.TextFrame2.TextRange.Text
                        strLeader = .Cell(2, 2).Shape.TextFrame2.TextRange.Text
                    End If
                End With
                Set pptTable = Nothing
                If blnHasData = True Then
                    Exit For
                End If
            End If
        Next
         
        lngRow = lngRow + 1
        With xlsWorksheet
            .Cells(lngRow, 1).Value = strFullPath
            If blnHasData = True Then
                .Cells(lngRow, 2).Value = strTeam
                .Cells(lngRow, 3).Value = strLeader
            Else
                .Cells(lngRow, 4).Value = "チーム表を検出できませんでした。"
            End If
        End With
         
        Set pptSlide = Nothing
        pptPresentation.Close
        Set pptPresentation = Nothing
         
        strPresentationName = Dir()
    Loop
     
    pptApp.Quit
    Set pptApp = Nothing
     
    xlsWorksheet.Cells.EntireColumn.AutoFit
     
    Set xlsWorksheet = Nothing
    Set xlsWorkbook = Nothing
 
End Sub
----------------------------------------------------------------
 
以上のようなコードを実行なさればよろしいのではないかと。

投稿日時: 19/10/25 08:36:28
投稿者: bunbun99

sk様
 
困りごとに親切に相談にのっていただき、大変感謝しております。
これで作業時間が短縮できそうです。
 
本当にありがとうございます!!!!