VBAでパワポ操作

Option Explicit


'  汎用変数
  Dim flg As Boolean
  Dim path As String
  Dim rng As Range
  Dim celary() As Variant
  Dim ary() As Variant

'  book,sheet変数
  Dim wb As Workbook
  Dim ws As Worksheet
  Dim wbdata As Workbook
  Dim wsdata As Worksheet


Sub main()
  
'  汎用変数
  Dim i As Long, k As Long, j As Long

'  book,sheet変数設定
  Set wb = ThisWorkbook
  Set ws = wb.Worksheets("ツール")
  path = ws.Range("_filepath")
  Set wbdata = Workbooks.Open(path)
  path = ws.Range("_wsname")
  Set wsdata = wbdata.Worksheets(path)

  
'  位置変数
  Dim row_codeSt As Long
  Dim row_codeEd As Long
  Dim col_code As Long

'  配列変数
  Dim ary_code() As Variant

  
  celary = wsdata.Range(wsdata.Cells(1, 1), wsdata.Cells(100, 100))
  For i = 1 To 100
    For k = 1 To 100
      If celary(i, k) = "codename" Then
        Set rng = wsdata.Cells(i, k)
      End If
    Next
  Next i
  row_codeSt = rng.Row
  col_code = rng.Column
  row_codeEd = wsdata.Cells(Rows.Count, col_code).End(xlUp).Row
  
  ary_code() = wsdata.Range(wsdata.Cells(row_codeSt + 1, col_code), wsdata.Cells(row_codeEd, col_code + 1))
  For i = 1 To UBound(ary_code, 1)
    ary_code(i, 2) = ""
  Next i
  
'  PwoerPoint
  Dim ppApp As New PowerPoint.Application
  Dim ppPt As Presentation
  Dim ppSlide As Slide
  Dim sh As PowerPoint.Shape
  Dim ppShape As PowerPoint.Shape
  
  
  Set ppPt = ppApp.Presentations.Open(ws.Range("_ppfilepath"))
'  Set ppPt = ppApp.ActivePresentation
  
  For i = ws.Range("_slidestart").Value To ws.Range("_slideend").Value Step 1
      Set ppSlide = ppPt.Slides(i)
      Call PowerPointDataCheckAndDelete(ary_code, ppSlide)
      
      For k = 1 To UBound(ary_code, 1)
        If ary_code(k, 2) = 1 Then
          wsdata.Cells(row_codeSt + k, col_code).Interior.Color = RGB(204, 126, 177)
        End If
      Next k
      
  Next i

End Sub


Sub PowerPointDataCheckAndDelete(ByRef ary_code, ByVal ppSld As Slide)

  Dim i As Long, j As Long, k As Long
  
  Dim rg As New RegExp

  Dim col As Long
  col = ws.Range("_検索列").Value

  Dim ppSh As PowerPoint.Shape
  Dim ary_cnt() As Variant

  For Each ppSh In ppSld.Shapes
    If ppSh.Type = msoTable Then
      ReDim ary(ppSh.Table.Rows.Count)
      For i = 1 To ppSh.Table.Rows.Count
        ary(i) = ppSh.Table.Cell(i, col).Shape.TextFrame.TextRange
      Next i
      
      rg.Global = True
      rg.Pattern = "[\s]"
      
      j = 0
      For i = 1 To UBound(ary)
        For k = 1 To UBound(ary_code, 1)
          If rg.Replace(ary(i), "") = rg.Replace(ary_code(k, 1), "") Then
            ary_code(k, 2) = 1
            ReDim Preserve ary_cnt(j)
            ary_cnt(j) = i
            j = j + 1
          End If
        Next k
      Next i
      

      For k = ppSh.Table.Rows.Count To 1 Step -1
      flg = False
        For i = 0 To UBound(ary_cnt)
          If k = ary_cnt(i) Then
            flg = True
          End If
        Next i
        If flg = False Then
          ppSh.Table.Rows(k).Delete
        End If
      Next k
      
    End If
 
  Next ppSh

End Sub