I have used the below VBA to update multiple links that are in a Powerpoint to an Excel Workbook. Some of the links update whereas some do not.
Please does anyone have any suggestions why it may not be working?
Any help appreciated.
Thanks
Dim oldFilePath As String
Dim newFilePath As String
Dim pptPresentation As Presentation
Dim pptSlide As Slide
Dim pptShape As Shape
'The old file path as a string (the text to be replaced)
oldFilePath = "N:\Finance\EXCEL\BUSINESS CENTRALS\Management accounts\April 2022 to March 2023\April 22\Management Accounts - Group April 22 - V8 - BRP TEST.xlsx"
'The new file path as a string (the text to replace with)
newFilePath = "N:\Finance\EXCEL\BUSINESS CENTRALS\Management accounts\April 2022 to March 2023\April 22\Management Accounts - Group April 22 - V8 - BRP.xlsx"
'Set the variable to the PowerPoint Presentation
Set pptPresentation = ActivePresentation
'Loop through each slide in the presentation
For Each pptSlide In pptPresentation.Slides
'Loop through each shape in each slide
For Each pptShape In pptSlide.Shapes
'Find out if the shape is a linked object or a linked picture
If pptShape.Type = msoLinkedPicture Or pptShape.Type _
= msoLinkedOLEObject Or pptShape.Type = msoLinkedChart Then
'Use Replace to change the oldFilePath to the newFilePath
pptShape.LinkFormat.SourceFullName = Replace(LCase _
(pptShape.LinkFormat.SourceFullName), LCase(oldFilePath), newFilePath)
End If
Next
Next
'Update the links
pptPresentation.UpdateLinks
End Sub```
Related
I have been trying to use excel VBA code from this website https://exceloffthegrid.com/edit-links-in-powerpoint-using-vba/. To give some context, I already have a PowerPoint with chart and table that is link from excel file. I would like to update the link to another new excel file using the code below.
'Set the link to the Object Library:
'Tools -> References -> Microsoft PowerPoint x.xx Object Library
Dim oldFilePath As String
Dim newFilePath As String
Dim sourceFileName As String
Dim pptApp As PowerPoint.Application
Dim pptPresentation As Object
Dim pptSlide As Object
Dim pptShape As Object
'The file name and path of the file to update
sourceFileName = "C:\File Path\Of Source File\File Name.pptx"
'The old file path as a string (the text to be replaced)
oldFilePath = "String of\File Path\To Be Replaced\Excel File.xlsx"
'The new file path as a string (the text to replace with)
newFilePath = "String of\New File Path\Excel File2.xlsx"
'Set the variable to the PowerPoint Application
Set pptApp = New PowerPoint.Application
'Make the PowerPoint application visible
pptApp.Visible = True
'Set the variable to the PowerPoint Presentation
Set pptPresentation = pptApp.Presentations.Open(sourceFileName)
'Loop through each slide in the presentation
For Each pptSlide In pptPresentation.Slides
'Loop through each shape in each slide
For Each pptShape In pptSlide.Shapes
'Find out if the shape is a linked object or a linked picture
If pptShape.Type = msoLinkedPicture Or pptShape.Type _
= msoLinkedOLEObject Or pptShape.Type = msoLinkedChart Then
'Use Replace to change the oldFilePath to the newFilePath
pptShape.LinkFormat.SourceFullName = Replace(LCase _
(pptShape.LinkFormat.SourceFullName), LCase(oldFilePath), newFilePath)
End If
Next
Next
pptPresentation.UpdateLinks
'Save, close and quit the application
pptPresentation.Save
pptPresentation.Close
pptApp.Quit
'Release the memory
Set pptApp = Nothing
Set pptPresentation = Nothing
Set pptSlide = Nothing
Set pptShape = Nothing
End Sub
I got an error. LinkFormat.SourceFullName : Failed. which is from this code
'Use Replace to change the oldFilePath to the newFilePath
pptShape.LinkFormat.SourceFullName = Replace(LCase _
(pptShape.LinkFormat.SourceFullName), LCase(oldFilePath), newFilePath)
Is there any setting that I have to do before running the code? Is there anyone have any idea?
My company uses a PowerPoint presentation that has linked Excel charts (namely, linked binary worksheet objects). Each month, the name of the workbook changes (from Feb to Mar, for instance) and the name of the folder the sheet is saved in changes as well. There are 40 links to update.
Does anyone know of a VBA script/macro to batch update the name of the links in PowerPoint? Currently, each link has to be updated individually.
When I run a script, nothing happens and no links update. The PowerPoint is macro-enabled.
I've tried a few different scripts, such as:
Sub switch()
Dim osld As Slide
Dim oshp As Shape
Dim oldPath As String
Dim newPath As String
Dim strLink As String
oldPath = "C:\Users\.xlsx\"
newPath = "C:\Users\.xlsx\"
For Each osld In ActivePresentation.Slides
For Each oshp In osld.Shapes
If oshp.HasChart Then
If oshp.LinkFormat.SourceFullName <> "" Then
strLink = oshp.LinkFormat.SourceFullName
oshp.LinkFormat.SourceFullName = Replace(strLink, oldPath, newPath)
Debug.Print oshp.LinkFormat.SourceFullName
oshp.LinkFormat.AutoUpdate = ppUpdateOptionAutomatic
oshp.LinkFormat.Update
End If
End If
Next oshp
Next osld
End Sub
Any insight would be appreciated.
Hi I have a code (see below) that is working like a charm to find and copy text from a specific style and paste it in another document. It is in an excel file because I preferred this option to share with friends that would only need to click in the button, chose the input file and save as their preferred output file name.
Now I'm trying without success to perform the same task with text highlighted in a specific color (e. Turquoise). Please find below the code that is working with a specific word or style, I made some experiences with code I found here and there, but all I could get was to copy all highlighted text instead of my choice of color. See below. Any help is much appreciated.
Note on Edit: The code below is the closer I get to the desired result. It was a little chaotic due to my try and error attempts.
' Objects
Dim wrdApp, objWord As Object
Dim wrdDoc, newwrdDoc As Object
Dim myPath As String, myPath1 As String
Dim folderPath As String
Dim myFile As String
Dim numberStart As Long
Dim Rng, srchRng As Excel.Range
'Dim objDoc As Document, objDocAdd As Document
Dim objRange As Range
Dim strFindColor As String
Dim highliteColor As Variant
Dim i As Long
' Close MS Word if it's already opened
On Error Resume Next
Set objWord = GetObject(, "Word.Application")
If Not objWord Is Nothing Then
objWord.Quit SaveChanges:=0
Set objWord = Nothing
End If
'Defining input file name
myFile = Application.GetOpenFilename()
'Open MS Word
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
' Folder Location
myPath = Application.ThisWorkbook.Path & "\"
' Input File
Set wrdDoc = wrdApp.Documents.Open(myFile)
' Output File
Set newwrdDoc = wrdApp.Documents.Add
myPath1 = Application.GetSaveAsFilename(FileFilter:="Word files(*.docx),*.docx")
' Text you want to search
'Dim FindWord As String
'Dim result As String
'FindWord = ""
highliteColor = Array(wdTurquoise)
'Style
'mystyle = wdTurquoise
'Defines selection for Word's find function
wrdDoc.SelectAllEditableRanges
' Find Functionality in MS Word
For i = LBound(wdTurquoise) To UBound(wdTurquoise)
objDoc.Activate
Selection.HomeKey Unit:=wdStory
objRange.Collapse wdCollapseEnd
With wrdDoc.ActiveWindow.Selection.Find
.HighlightColorIndex = wdTurquoise
.Highlight = True
.Forward = True
.Wrap = wdFindStop
objRange = Selection.Range
objDocAdd.Range.InsertAfter objRange & vbCr
Selection.Collapse wdCollapseEnd
End With
Next
' Execute find method
wrdDoc.ActiveWindow.Selection.Find.Execute
' Store Selected text
result = wrdDoc.ActiveWindow.Selection.Text
' Check if result contains non-blank text
If Len(result) > 1 Then
' -------------------------------------------------------------
' Loop through multiple find content (Find All functionality)
' -------------------------------------------------------------
While wrdDoc.ActiveWindow.Selection.Find.Found
wrdDoc.ActiveWindow.Selection.Copy
'Activate the new document
newwrdDoc.Activate
'New Word Doc
Set Rng = newwrdDoc.Content
Rng.Collapse Direction:=wdCollapseEnd
Rng.Paste
'Word Document
wrdDoc.Activate
wrdDoc.ActiveWindow.Selection.Find.Execute
Wend
' If style not found
Else
MsgBox "Text Not Found"
End If
'Close and don't save application
wrdDoc.Close SaveChanges:=False
'Save As New Word Document
newwrdDoc.SaveAs myPath1
newwrdDoc.Close SaveChanges:=True
'Close all word documents
wrdApp.Quit SaveChanges:=0
'Message when done
MsgBox "Task Accomplished"
End Sub
I am trying to write a PowerPoint VB application which needs to display certain values from a text file in a fixed format.
When I (manually) open that text file as a csv file in Excel, I get the required values in fixed cells and I know how continue from there by VBA.
What I do not know is how to create the Excel spreadsheet using a macro in PowerPoint.
Also, I want to make sure that the parameters for opening the file (using space as delimiter; multiple spaces count as one) are defined in the macro so that I do not have to rely on current local settings.
Thanks in advance for any idea or reference.
use ~.OpenText
it Supports consecutive delimiter
2.Use text file not with .csv but with .txt extension
Excel fails to load a text with other delimiter if it's extension is '.csv'
Following macro reads a text file with delimiters of space character and copies the Excel table to Powerpoint Table on a Slide.
Full code:
Sub ReadCSV()
Dim xlsApp As Excel.Application
Dim xlsWb As Excel.Workbook
Dim xlsSht As Object 'Excel.Worksheet
Dim rng As Object 'Excel.Range
Dim Target As String
On Error GoTo Oops
'Set xlsApp = New Excel.Application
Set xlsApp = CreateObject("Excel.Application")
xlsApp.Visible = True
Target = ActivePresentation.Path & "\test_space.txt"
'Below don't support consecutive delimiters
'Set xlsWb = xlsApp.Workbooks.Open(FileName:=Target, Format:=3)
'File Extension .CSV won't work here. .TXT works.
xlsApp.Workbooks.OpenText FileName:=Target, Origin:=2, StartRow:=1, _
DataType:=1, ConsecutiveDelimiter:=True, Space:=True, Local:=True
Set xlsWb = xlsApp.ActiveWorkbook
Set xlsSht = xlsWb.Worksheets(1)
Dim sld As Slide
Dim shp As Shape
Dim tbl As Table
Dim numRow As Long, numCol As Long
Dim r As Long, c As Long
Set rng = xlsSht.UsedRange
numRow = rng.Rows.Count
numCol = rng.Columns.Count
With ActivePresentation
Set sld = .Slides.Add(.Slides.Count + 1, ppLayoutBlank)
End With
Set shp = sld.Shapes.AddTable(numRow, numCol, 100, 100, 200, 150)
shp.Name = "Table"
Set tbl = shp.Table
'Copy cell values from Excel Table to Powerpoint Table
For r = 1 To numRow
For c = 1 To numCol
tbl.Cell(r, c).Borders(ppBorderBottom).ForeColor.RGB = rgbBlack
With tbl.Cell(r, c).Shape.TextFrame
If r > 1 Then .Parent.Fill.ForeColor.RGB = rgbWhite
.VerticalAnchor = msoAnchorMiddle
.TextRange = rng.Cells(r, c)
.TextRange.ParagraphFormat.Alignment = ppAlignCenter
End With
Next c
Next r
xlsWb.Close False
Oops:
If Err.Number Then MsgBox Err.Description
'If Excel App remains in the system process, Excel App won't respond and run again.
If Not xlsApp Is Nothing Then xlsApp.Quit: Set xlsApp = Nothing
End Sub
I need to grab a list of names from Excel and insert them into a Word document, printing one document per name. The document has some text and a bookmark called "name". The code is below.
First, I want to know if it's possible to detect how long is the list of names in the Excel spreadsheet and grab that, instead of hardcoding the number.
Second, I can't figure out how to delete the text I already put inside the document. When I insert text in a bookmark, it gets appended after the bookmark, so if I keep adding names they all stack together.
Maybe with the code this will be clearer:
Sub insertar_nombre()
Dim Excel As Excel.Application
Dim Planilla As Excel.Workbook
Dim Hoja As Excel.Worksheet
Set Excel = CreateObject("Excel.Application")
Dim Filename As String
Dim fname As Variant
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Title = "Seleccionar Documento de Excel"
.Show
For Each fname In .SelectedItems
Filename = fname
Next
End With
Set Planilla = Excel.Workbooks.Open(Filename)
Set Hoja = Planilla.Worksheets(1)
Dim Nombre As String
For Count = 2 To 10
Nombre = Hoja.Cells(Count, 1).Value
ActiveDocument.Bookmarks("name").Range.Text = Nombre
ActiveDocument.PrintOut
Next
End Sub
Forgive me if this code is obviously wrong or something, I'm just beginning with this.
I need to grab a list of names from Excel and insert them into a Word document, printing one document per name.
Why don't you simply use the mail merge feature?
the following Sub should solve this for you, but you might need to change the way your bookmark is defined.
There is more than one way to insert a Bookmark. This method requires the Bookmark to be inserted by highlighting the text, not simply positioning the cursor at a location in the text.
Sub insertar_nombre()
Dim xlWorkbook As Excel.Workbook
Dim xlWorksheet As Excel.Worksheet
Dim strFilename As String
Dim bkmName As Word.Range
Dim strBookmarkOriginalText As String
Dim lngRowLast As Long
Dim rngRowStart As Excel.Range
Dim rngRowEnd As Excel.Range
Dim rngNames As Excel.Range
Dim rngName As Excel.Range
'Open file dialog and only allow Excel files'
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Title = "Seleccionar Documento de Excel"
'Only let them select Excel files'
.Filters.Clear
.Filters.Add "Excel Documents (*.xls)", "*.xls"
'Check if a file is selected'
If .Show = True Then
'Since AllowMultiSelect is set to False, _
only one file can be selected'
strFilename = .SelectedItems(1)
Else
'No file selected, so exit the Sub'
Exit Sub
End If
End With
'Set the bookmark to a Word range (not a Bookmark object)'
Set bkmName = ActiveDocument.Bookmarks("name").Range
'Save the original text of the bookmark'
strBookmarkOriginalText = bkmName.Text
'Open the Excel file'
Set xlWorkbook = Excel.Workbooks.Open(strFilename)
Set xlWorksheet = xlWorkbook.Worksheets(1)
'Range of the first cell that contains a name'
Set rngRowStart = xlWorksheet.Cells(2, 1)
'Range of the last cell in the column'
lngRowLast = xlWorksheet.Range("A65536").End(xlUp).Row
Set rngRowEnd = xlWorksheet.Cells(lngRowLast, 1)
'Range of all cells from first name cell to last name cell'
Set rngNames = xlWorksheet.Range(rngRowStart, rngRowEnd)
'Loop through the range of names'
For Each rngName In rngNames
'Ignore any blank cells'
If rngName <> vbNullString Then
'Set the text of the bookmark range to the name from Excel'
bkmName.Text = rngName
'The above statement deleted the Bookmark, so create _
a new Bookmark using the range specified in bkmName'
ActiveDocument.Bookmarks.Add Name:="name", Range:=bkmName
'Print the document'
ActiveDocument.PrintOut
End If
Next
'Restore the orignal value of the bookmark'
bkmName.Text = strBookmarkOriginalText
ActiveDocument.Bookmarks.Add Name:="name", Range:=bkmName
'Close the Workbook without saving'
xlWorkbook.Close SaveChanges:=False
End Sub
Hope this helps.