View Single Post
 
Old 11-09-2023, 06:49 AM
gmaxey gmaxey is offline Windows 10 Office 2019
Expert
 
Join Date: May 2010
Location: Brasstown, NC
Posts: 1,601
gmaxey is just really nicegmaxey is just really nicegmaxey is just really nicegmaxey is just really nicegmaxey is just really nice
Default

It was an array dimension issue. Try:


Code:
Sub FormatByExcel()
'Code by Gregory K. Maxey
Dim xlapp As Object
Dim xlbook As Object
Dim xlsheet As Object
Dim bStartApp As Boolean
Dim varArray As Variant
Dim FD As FileDialog
Dim strSource As String
Dim lngIndex As Long
Dim oSld As Slide
Dim oShp As Shape
Dim oTxtRng As TextRange
Dim oFoundTxt As TextRange
  '**** This is the basically the same as Doug's original code
  Set FD = Application.FileDialog(msoFileDialogFilePicker)
  With FD
    .Title = "Select the workbook that contains the terms to be italicized"
    .Filters.Clear
    .Filters.Add "Excel Workbooks", "*.xlsx"
    .AllowMultiSelect = False
    If .Show = -1 Then
      strSource = .SelectedItems(1)
    Else
      MsgBox "You did not select the workbook that contains the data"
      Exit Sub
    End If
  End With
  On Error Resume Next
  Set xlapp = GetObject(, "Excel.Application")
  If Err Then
    bStartApp = True
    Set xlapp = CreateObject("Excel.Application")
  End If
  On Error GoTo 0
  Set xlbook = xlapp.Workbooks.Open(strSource)
  Set xlsheet = xlbook.Worksheets(1)
  varArray = xlsheet.Range("A1").CurrentRegion.Value
  If bStartApp = True Then xlapp.Quit
  Set xlapp = Nothing
  Set xlbook = Nothing
  Set xlsheet = Nothing
  '****
'  '#### Since I don't have your Excel file, this is simply for testing
'  ReDim varArray(1)
'  varArray(0) = "Apples"
'  varArray(1) = "Oranges"
'  '####
  '@@@@ I am far from a PowerPoint expert, but a causal Google search turned up something that I could adapt to suit.
  For lngIndex = 1 To UBound(varArray)
    'Loop through each slide in presentation
    For Each oSld In ActivePresentation.Slides
      'Loop through each shape on slide
      For Each oShp In oSld.Shapes
        'Is there text in the shape?
        If oShp.HasTextFrame Then
          Set oTxtRng = oShp.TextFrame.TextRange
          Set oFoundTxt = oTxtRng.Find(FindWhat:=varArray(lngIndex, 1))
          Do While Not (oFoundTxt Is Nothing)
            With oFoundTxt
              .Font.Italic = True
              Set oFoundTxt = oTxtRng.Find(FindWhat:=varArray(lngIndex, 1), After:=.Start + .Length - 1)
            End With
          Loop
        End If
      Next oShp
    Next oSld
  Next lngIndex
lbl_Exit:
  Exit Sub
End Sub
__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/
Reply With Quote