#1
|
|||
|
|||
Convert a word VBA code to PowerPoint VBA code
I have this VBA code, which was developed by DougRobbin
This code Format Scientific Names which are present in the main body of the document and in the text boxes in a word document according to the list of microbial names in Excel file. Now I want the same code for the same purpose, but to work inside PowerPoint, Nowadays I made many seminars, which include microbial names and I change formatting for each one manually, which is so annoying. So I want a code to do this automatically in PowerPoint. Thanks Code:
Sub FormatByExcel() Dim xlapp As Object Dim xlbook As Object Dim xlsheet As Object Dim myarray As Variant Dim FD As FileDialog Dim strSource As String Dim i As Long, lognum As Long Dim myStoryRange As range 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) myarray = xlsheet.range("A1").CurrentRegion.Value If bStartApp = True Then xlapp.Quit End If Set xlapp = Nothing Set xlbook = Nothing Set xlsheet = Nothing Application.ScreenUpdating = False For i = LBound(myarray) To UBound(myarray) Selection.HomeKey wdStory Selection.Find.ClearFormatting With Selection.Find Do While .Execute(findText:=myarray(i, 1), Forward:=True, _ MatchWildcards:=False, Wrap:=wdFindStop, MatchCase:=True) = True Set Rng = Selection.range Selection.Collapse wdCollapseEnd Rng.Font.Italic = True Loop End With For Each myStoryRange In ActiveDocument.StoryRanges myStoryRange.Select With Selection.Find Do While .Execute(findText:=myarray(i, 1), Forward:=True, _ MatchWildcards:=False, Wrap:=wdFindStop, MatchCase:=True) = True Set Rng = Selection.range Selection.Collapse wdCollapseEnd Rng.Font.Italic = True Loop End With Do While Not (myStoryRange.NextStoryRange Is Nothing) Set myStoryRange = myStoryRange.NextStoryRange myStoryRange.Select With Selection.Find Do While .Execute(findText:=myarray(i, 1), Forward:=True, _ MatchWildcards:=False, Wrap:=wdFindStop, MatchCase:=True) = True Set Rng = Selection.range Selection.Collapse wdCollapseEnd Rng.Font.Italic = True Loop End With Loop Next myStoryRange Next i With Application .ScreenUpdating = True .ScreenRefresh .ActiveWindow.View = wdPrintView End With End Sub |
#2
|
|||
|
|||
This is not a PowerPoint forum but perhaps:
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 = 0 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)) Do While Not (oFoundTxt Is Nothing) With oFoundTxt .Font.Italic = True Set oFoundTxt = oTxtRng.Find(FindWhat:=varArray(lngIndex), After:=.Start + .Length - 1) End With Loop End If Next oShp Next oSld Next lngIndex lbl_Exit: Exit Sub End Sub |
#3
|
|||
|
|||
Excuse me, I am sorry for this misposting
Dear gmaxey, after running the code and choosing the Excel file, nothing happens I attached my files to apply. Thanks with my best regards |
#4
|
|||
|
|||
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 |
#5
|
|||
|
|||
Dear Greg Maxey
It works perfectly Thanks so much You saved my time Thank you, That’s very kind of you Thanks for your time and consideration I can't thank you enough I wholeheartedly appreciate everything you’ve done for me Thank you again Best wishes |
#6
|
|||
|
|||
You are certainly welcome. Again, not a PowerPoint coder so how efficient it is questionable.
|
Tags |
find & replace, power automate, wordvba |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Convert Text Boxes to Normal Text in Word Using VBA Code | laith93 | Word VBA | 2 | 03-09-2023 11:51 PM |
List of ascii code of Character Symbols or code for all symbols used in Word | SamDsouza | Word VBA | 3 | 03-12-2020 04:49 AM |
How I convert formua into VBA code I need help | Moot70 | Excel Programming | 1 | 10-27-2019 06:15 AM |
Code to convert numbers to superscript | SidCharming | Word VBA | 2 | 08-09-2018 08:21 AM |
VBA code to convert Heading 1, 2, 3 etc. numbering | Lady_Laughsalot | Word VBA | 4 | 04-18-2018 12:32 AM |