I wonder if there is someone who can help me make this code work in my MAC. I recently posted this query two times but I got no solution. Because there are very few VBA experts who know to write VBA for MAC.
So here is the VBA Macro Code which I'm using in my Windows PowerPoint perfectly. But now I've recently moved to MAC OS. And I want this same file to work on Mac as well.
Unfortunately! Its not working and there is no Error message And nothing happening when I run this Macro on MAC version big sur (11.6.2) and, Microsoft Office PowerPoint version 365.
Here is the Code for it:
Dim slideShowRunning As Boolean
Dim counter As Integer
Dim st As Dat
Dim i As Integer
Dim sttime As Date
Dim oxlapp As Object
Dim oxlwb As Object
Dim oxlws As Object
Dim edtime As Date
Sub SlideShowBegin(ByVal Wn As SlideShowWindow)
st = Date
sttime = Time
counter = 0
Debug.Print " works;1 "
Set oxlapp = CreateObject("Excel.Application")
Debug.Print " works; 2"
oxlapp.Visible = False
Debug.Print " works; 3"
Set oxlwb = oxlapp.Workbooks.Open(ActivePresentation.Path & Application.PathSeparator & "record.xlsx")
Debug.Print " works; 4"
Set oxlws = oxlwb.Sheets("TimeRecord")
Debug.Print " works; 5"
i = oxlws.Range("A99919").End(-4162).Row
oxlws.Range("A1").Offset(i, 0).Value = st
oxlws.Range("A1").Offset(i, 1).Value = sttime
Debug.Print " works; 6"
End Sub
Public Sub OnSlideShowPageChange(ByVal Wn As SlideShowWindow)
If TypeName(slideShowRunning) = "Empty" Or slideShowRunning = False Then
slideShowRunning = True
SlideShowBegin Wn
End If
End Sub
Public Sub OnSlideShowTerminate(ByVal Wn As SlideShowWindow)
Name = Application.ActivePresentation.Name
slideShowRunning = False
edtime = Time
Debug.Print " works; 7"
ivalue = DateDiff("s", sttime, edtime)
Debug.Print ivalue
oxlws.Range("A1").Offset(i, 2).Value = edtime
oxlws.Range("A1").Offset(i, 3).Value = ivalue
oxlws.Range("A1").Offset(i, 4).Value = Name
Debug.Print " works; 9"
oxlapp.DisplayAlerts = False
Debug.Print " works; 10"
oxlwb.Save
Debug.Print " works; 11"
oxlapp.Visible = True
Debug.Print " works; 12"
oxlapp.DisplayAlerts = True
Debug.Print " works; 13"
End Sub
Note:
The code stores the PowerPoint slide Name along with slide opening time and slide closing time.
The details are stored in an Excel Sheet.
The code doesn't work when I run it on MAC.
I know there are few changes that need to be done to make it work on Mac but till now I've find anyone to help me modifying this code well.
I request VBA Experts for any kind of Help.
CreateObject is broken in the PowerPoint for Mac object model. Please report this to Microsoft, perhaps if they get a few thousand requests, they'll finally fix it.
Paste your code onto a slide, so they can see it. Then click on the "person-with-speech-bubble" icon in the upper right corner of the program window and choose I don't like something. Describe the problem, include a screenshot of your code and submit. They are unlikely to reply, but it's the best you can do.
Finally, after some struggle and editing, I managed to run this code on my MAC.
Here is the code:
Dim slideShowRunning As Boolean
Dim counter As Integer
Dim st As Date
Dim i As Integer
Dim sttime As Date
Dim oxlapp As Object
Dim oxlwb As Object
Dim oxlws As Object
Dim edtime As Date
Public Sub OnSlideShowPageChange(ByVal Wn As SlideShowWindow)
If TypeName(slideShowRunning) = "Empty" Or slideShowRunning = False Then
slideShowRunning = True
st = Date
sttime = Time
counter = 0
Set oxlapp = CreateObject("Excel.Application")
oxlapp.Visible = False
Set oxlwb = oxlapp.Workbooks.Open(ActivePresentation.Path & "/" & "record.xlsx")
Set oxlws = oxlwb.Sheets("TimeRecord")
i = oxlws.Range("A99919").End(-4162).Row
oxlws.Range("A1").Offset(i, 0).Value = st
oxlws.Range("A1").Offset(i, 1).Value = sttime
End If
End Sub
Public Sub OnSlideShowTerminate(ByVal Wn As SlideShowWindow)
Name = Application.ActivePresentation.Name
slideShowRunning = False
edtime = Time
Debug.Print " works; 7"
ivalue = DateDiff("s", sttime, edtime)
Debug.Print ivalue
oxlws.Range("A1").Offset(i, 2).Value = edtime
oxlws.Range("A1").Offset(i, 3).Value = ivalue
oxlws.Range("A1").Offset(i, 4).Value = Name
Debug.Print " works; 9"
oxlapp.DisplayAlerts = False
Debug.Print " works; 10"
oxlwb.Save
Debug.Print " works; 11"
' oxlwb.Close
oxlapp.Visible = True
Debug.Print " works; 12"
oxlapp.DisplayAlerts = True
Debug.Print " works; 13"
End Sub
Any improvement suggestion appreciated.
Related
Right now I have 8 different textbox controls on a UserForm that when a value is entered a macro runs to open a workbook saved on a network folder then a VLookup is run. Below is the code for two of the TextBox controls and as you can see (due to my lack of coding ability); I ended up with 8 separate subs for each of the text boxes which opens up the workbook on the shared drive after a value is entered in the text box then closes the workbook and is not very efficient. After some research I am thinking of using Index and Match would be a better solution, but have no familiarity with those excel functions in VBA and could use some help with getting a starting point using Index and Match, if that is a better solution. Thank you all for your assistance.
Sub b1CIF()
Dim CustList As Workbook
Dim thisWB As Workbook
Dim thisWS As Worksheet
Dim wsRR As Worksheet
Dim bColor As Range
Dim Msg, Style, Title, Response
Msg = "OOOPS!" & vbNewLine & vbNewLine & "The CIF Number of " & LendStart.lsPBCIF.Value & " " & "is not correct or does not exist." & vbNewLine & "Please re-enter the CIF Number."
Style = vbOKCancel + vbCritical
Title = UCase("***CIF Data Entry Error!***")
Application.ScreenUpdating = False
Set CustList = Workbooks.Open("L:\Deposits\Information\Customers.xlsm")
Set thisWB = ThisWorkbook
Set thisWS = thisWB.Sheets("SavedInfo")
Set wsRR = thisWB.Sheets("RiskRating")
Set bColor = wsRR.Range("C3")
On Error GoTo ErrHandler
' NAME GRAB
If thisWS.Range("A2") <> "" Then
thisWS.Range("PBName").Value = _
WorksheetFunction.VLookup(thisWS.Range("A2").Value, CustList.Sheets("CIFMAST").Range("A1:Z50000"), 2, False)
With LendStart.lsPBName
.Value = thisWS.Range("PBName")
.Visible = True
.Locked = True
.BackColor = bColor.Interior.Color
.Font.Bold = True
.Font.Size = 9
.TextAlign = fmTextAlignCenter
.TabStop = False
End With
thisWB.Sheets("BorrInfo").Range("PB").Value = thisWS.Range("PBName")
' TELEPHONE NUMBER GRAB
thisWB.Sheets("BorrInfo").Range("PBPhone").Value = _
WorksheetFunction.VLookup(thisWS.Range("A2").Value, CustList.Sheets("CIFMAST").Range("A1:Z50000"), 9, False)
End If
CustList.Close
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
LendStart.lsPBSCIF.Value = ""
With LendStart.lsPBName
.Value = ""
.Locked = True
End With
Response = MsgBox(Msg, Style, Title)
CustList.Close
Application.ScreenUpdating = True
End Sub
Sub b2CIF()
Dim CustList As Workbook
Dim thisWB As Workbook
Dim thisWS As Worksheet
Dim wsRR As Worksheet
Dim bColor As Range
Dim Msg, Style, Title, Response
Msg = "The CIF Number entered " & LendStart.lsPBSCIF.Value & " " & "is not correct." & vbNewLine & "Please re-enter the CIF Number."
Style = vbOKCancel + vbCritical
Title = UCase("***CIF data entry error!***")
Application.ScreenUpdating = False
Set CustList = Workbooks.Open("L:\Deposits\Information\Customers.xlsm")
Set thisWB = ThisWorkbook
Set thisWS = thisWB.Sheets("SavedInfo")
Set wsRR = thisWB.Sheets("RiskRating")
Set bColor = wsRR.Range("C3")
On Error GoTo ErrHandler
' NAME GRAB
If thisWS.Range("A3") <> "" Then
thisWS.Range("PBSName").Value = _
WorksheetFunction.VLookup(thisWS.Range("A3").Value, CustList.Sheets("CIFMAST").Range("A1:Z50000"), 2, False)
With LendStart.lsPBSName
.Value = thisWS.Range("PBSName")
.Visible = True
.Locked = True
.BackColor = bColor.Interior.Color
.Font.Bold = True
.Font.Size = 9
.TextAlign = fmTextAlignCenter
.TabStop = False
End With
thisWB.Sheets("BorrInfo").Range("PBS").Value = thisWS.Range("PBSName")
' TELEPHONE NUMBER GRAB
thisWB.Sheets("BorrInfo").Range("PBSPhone").Value = _
WorksheetFunction.VLookup(thisWS.Range("A3").Value, CustList.Sheets("CIFMAST").Range("A1:Z50000"), 9, False)
End If
CustList.Close
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
LendStart.lsPBSCIF.Value = ""
Response = MsgBox(Msg, Style, Title)
CustList.Close
Application.ScreenUpdating = True
End Sub
Im making a new excel template where the managers can add info so that we can make a quote based on their template. The meaning is that if they are clicking on the submit button that depending on the value segment gos to the correct excel file (follow up list) and that the customer name, customer id and general info put in the follow up list.
This is de code that i have until now, only thing is the submit button that i need to have.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("B7")) Is Nothing Then
If Range("B7") <> "Server & Storage" And Range("B7") <> "Power" And Range("B7") <> "Networking" And Range("B7") <> "Software" And Range("B7") <> "Printing" Then
MsgBox "Selecteer een value segment!"
End If
Else
Exit Sub
End If
End Sub
'E-mail knop
Private Sub CommandButton1_Click()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Dim srtEmail As String
On Error Resume Next
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Hi Team," & vbNewLine & vbNewLine & _
"Dit is een nieuwe request voor " & Range("B8")
If Range("B7") = "Server & Storage" Then
srtEmail = "hardware#bechtle.be"
Else
If Range("B7") = "Power" Then
srtEmail = "hardware#bechtle.be"
Else
If Range("B7") = "Networking" Then
srtEmail = "networking#bechtle.be"
Else
If Range("B7") = "Software" Then
srtEmail = "software#bechtle.be"
Else
If Range("B7") = "Printing" Then
srtEmail = "kristof.neubauer#bechtle.com"
Else
MsgBox "Geen value segment geselecteerd!"
End If
End If
End If
End If
End If
On Error Resume Next
With xOutMail
.To = srtEmail
.CC = "berty.vaneijgen#bechtle.com"
.BCC = ""
.Subject = "Value Request voor " & Range("B9") & Range("B8")
.Body = xMailBody
If Range("B7") <> "" Then
.Display 'or use .Send
End If
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
'Reset knop
Private Sub CommandButton2_Click()
Sheets("VRT").Range("B7:B33") = ""
MsgBox "Velden zijn gewist!"
End Sub
'Save as knop
Private Sub CommandButton3_Click()
Dim nom As String
nom = Day(Date) & "-" & Month(Date) & "-" & Year(Date) & " " & Range("B8")
ActiveWorkbook.SaveCopyAs ActiveWorkbook.Path & "\" & nom & ".xlsm"
rep = MsgBox("Je bestand is opgeslagen! ", vbYes + vbInformation, "Copy of spreadsheet")
'MsgBox(You database has been saved : " & Name, vbYes + vbInformation, "Copy of spreadsheet")
End Sub
'print
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Cancel = (ActiveSheet.Name = "VRT")
If Cancel = True Then MsgBox "Gebruik de print knop."
End Sub
'print knop
Private Sub CommandButton4_Click()
On Error Resume Next
Application.EnableEvents = False
With ActiveWorkbook.Sheets("VRT")
.Range("A1:F33").PrintOut
End With
Application.EnableEvents = True
On Error GoTo 0
End Sub
Private Sub CommandButton5_Click()
End Sub
You can open the developer tab and create a button. How to show developer tab on the ribbon MSDN.
Create an ActiveX button, by clicking the Developer Tab > Insert > Command Button:
Then make sure that the name of the button is CommandButton1, to be compatible with your code. This is where to rename the name of the button:
Since you mentioned that you have the code, and only need to add the button, these steps may be what you need to follow.
-Add a button from the 'Developer' tab using the Insert group
-Right-click on the button to 'Assign macro..'. You will see a list of subs
present in the workbook to select from.
-For the code use something like this
Dim src, dst as Workbook
dst= ThisWorkbook 'Destination is your current workbook
'Define the src inside your IF-ELSE tree based on 'B7' cell value
'Use the statement below for each cell value with address in the 'Range' quotes
dst.Range("").Value= src.Range("").Value
I am developing a user form as you can see below
enter image description here
the code in the Browse Button is
Private Sub Browse_Click()
Dim fName As String
fName = Application.GetOpenFilename("CSV File (*.csv), *.csv", , "Import .CSV File", , False)
If Not fName = "False" Then
TextBox1.Value = fName
End If
End Sub
Next step is to choose some of these options and the code behind it is
Private Sub Start_Click()
Dim Actsheet As String
Dim wkbCrntWorkBook As Workbook
Dim wkbSourceBook As Workbook
Dim rngSourceRange As Range
Dim rngDestination As Range
Set wkbCrntWorkBook = ActiveWorkbook
Set rngDestination = wkbCrntWorkBook.ActiveSheet.Range("A1:A1")
If myBeforeImprovements = True Then
Actsheet = "Before "
ElseIf AfterImprovements = True Then
Actsheet = "After "
Else
MsgBox ("Select Type of Analysis")
Exit Sub
End If
If Westbound = True Then
Actsheet = Actsheet & "WB"
ElseIf Northbound = True Then
Actsheet = Actsheet & "NB"
ElseIf Eastbound = True Then
Actsheet = Actsheet & "EB"
ElseIf Southbound = True Then
Actsheet = Actsheet & "SB"
Else
MsgBox ("Select Traffic Bound")
Exit Sub
End If
my problem is I can't take the CSV file to its write sheet which are
Before EB
Before WB
Before NB
Before SB
After EB
After WB
After NB
After SB
maybe the following code will refer to the selected CSV file but it gives me an error
Workbooks.OpenText Filename:=TextBox1.Text + "," + ComboBox1.Value + ".txt", _
DataType:=xlDelimited, Tab:=True
Replace + with & and it'll hopefully work better. The concatenation operator is & in VBA
I create a sales proposal from data entered into an Excel spreadsheet using a macro, then I call a macro to import some 'stock' pictures depending on the data that was entered into the spreadsheet. This second macro is saved in the normal.dot document and called by the following code:
WordObj.Run ("normal!Picture") 'this calls a macro in Word which works and debugs perfectly
end sub
When the macro finishes and gives the final message stating that the document successfully finished and goes to the 'end sub' on the Word macro I get an error message stating that Excel has crashed and needs to be restarted!
These macros were created in 2002 and have worked throughout every version of Office, but we are starting to upgrade to Office 2010 and now when I run this macro it crashes Excel (only on Office 2010 clients).
I suppress messages but here is a related message that I get if I unsuppress errors:
"Microsoft Excel is waiting for another application to complete OLE action", but I believe this is happening when it's trying to open WORD.
In my limited VBA experience, I think that the focus needs to be sent back to the macro in Excel so it can end it's sub properly. I am thinking that the Word macro is completing properly but not letting the last 'end sub' run in the Excel macro. However I can't figure out how to put the focus back in the Excel macro.
I will be checking my email regularly and working diligently on this. If I happen to find a solution I will post it immediately.
Excel Macro:
Sub Proposal1()
Dim appwd As Object
Dim bookmark1 As String
Dim test As String
Dim ans As String
Dim company As String
Dim goOn As Integer
company = Range("survey!D1")
goOn = MsgBox(prompt:="Do you want to create a proposal for " & company & " at this time?", _
Buttons:=vbYesNo)
If goOn = vbNo Then Exit Sub
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="c:\sales\salescalc.xls"
Application.DisplayAlerts = True
Static WordObj As Word.Application
Set WordObj = Nothing
Set WordObj = CreateObject("Word.Application")
WordObj.Visible = True
With WordObj
.Documents.Add Template:=("C:\sales\sales\proposal1.dot")
On Error Resume Next
'Bunch of logic here that reads cells and inputs text to word doc'
'about 150 lines of code all runs normal'
End With
End Sub
WORD MACRO:
Sub picture()
Dim oExcel As Object
Dim oWorkbook As Object
Dim oWorkSheet As Object
Dim verbiage As String
Dim doc As Word.Document
Dim bkmname As String
Dim bkname2 As String
Dim bkname3 As String
Dim verbiage2 As String
Dim verbiage3 As String
Dim spec1 As InlineShape
Dim spec2 As InlineShape
Dim spec3 As InlineShape
Dim pic1 As InlineShape
Dim pic2 As InlineShape
Dim pic3 As InlineShape
Dim pic4 As InlineShape
Dim pic5 As InlineShape
Dim vpic1 As String
Dim company As String
Dim myfolder As String
Dim foldername As String
Set fs = CreateObject("Scripting.FileSystemObject")
Set oExcel = GetObject(, "Excel.Application")
oExcel.Visible = True
Set oWorkbook = oExcel.Workbooks.Open("c:\sales\salescalc.xls")
Set oWorkSheet = oWorkbook.Sheets("survey")
bkmname = "SO1"
bkmname2 = "SO2"
bkmname3 = "SO3"
vpic1 = "pic1"
company = oWorkSheet.Range("d1").Value
myfolder = "C:\proposals\"
Set doc = ActiveDocument
If oWorkSheet.Range("b15").Value > 0 Then
Set pic1 = Selection.InlineShapes.AddPicture(FileName:= _
myfolder & company & "\pics\pic1.jpg" _
, linktofile:=False, savewithdocument:=True, Range:=doc.Bookmarks("pic1").Range)
With pic1
.Width = InchesToPoints(2.46)
.Height = InchesToPoints(1.69)
End With
End If
If oWorkSheet.Range("b16").Value > 0 Then
Set pic2 = Selection.InlineShapes.AddPicture(FileName:= _
myfolder & company & "\pics\pic2.jpg" _
, linktofile:=False, savewithdocument:=True, Range:=doc.Bookmarks("pic2").Range)
With pic2
.Width = InchesToPoints(2.46)
.Height = InchesToPoints(1.69)
End With
End If
If oWorkSheet.Range("b17").Value > 0 Then
Set pic3 = Selection.InlineShapes.AddPicture(FileName:= _
myfolder & company & "\pics\pic3.jpg" _
, linktofile:=False, savewithdocument:=True, Range:=doc.Bookmarks("pic3").Range)
With pic3
.Width = InchesToPoints(2.46)
.Height = InchesToPoints(1.69)
End With
End If
If oWorkSheet.Range("b18").Value > 0 Then
Set pic4 = Selection.InlineShapes.AddPicture(FileName:= _
myfolder & company & "\pics\pic4.jpg" _
, linktofile:=False, savewithdocument:=True, Range:=doc.Bookmarks("pic4").Range)
With pic4
.Width = InchesToPoints(2.46)
.Height = InchesToPoints(1.69)
End With
End If
If oWorkSheet.Range("b19").Value > 0 Then
Set pic5 = Selection.InlineShapes.AddPicture(FileName:= _
myfolder & company & "\pics\pic5.jpg" _
, linktofile:=False, savewithdocument:=True, Range:=doc.Bookmarks("pic5").Range)
With pic5
.Width = InchesToPoints(2.46)
.Height = InchesToPoints(1.69)
End With
End If
Set doc = ActiveDocument
If oWorkSheet.Range("b7") > 0 Then
verbiage = oWorkSheet.Range("H27").Value
Set spec1 = Selection.InlineShapes.AddPicture(FileName:="c:\sales\spec\" & verbiage & ".gif" _
, linktofile:=False, savewithdocument:=True, Range:=doc.Bookmarks(bkmname).Range)
With spec1
.Width = InchesToPoints(4.17)
.Height = InchesToPoints(2.83)
End With
End If
If oWorkSheet.Range("b8") > 0 Then
verbiage2 = oWorkSheet.Range("H28").Value
Set spec2 = Selection.InlineShapes.AddPicture(FileName:= _
"C:\sales\spec\" & verbiage2 & ".gif" _
, linktofile:=False, savewithdocument:=True, Range:=doc.Bookmarks(bkmname2).Range)
With spec2
.Width = InchesToPoints(4.17)
.Height = InchesToPoints(2.83)
End With
End If
If oWorkSheet.Range("b9") > 0 Then
verbiage3 = oWorkSheet.Range("H29").Value
Set spec3 = Selection.InlineShapes.AddPicture(FileName:= _
"C:\sales\spec\" & verbiage3 & ".gif" _
, linktofile:=False, savewithdocument:=True, Range:=doc.Bookmarks(bkmname3).Range)
With spec3
.Width = InchesToPoints(4.17)
.Height = InchesToPoints(2.83)
End With
End If
ActiveDocument.SaveAs FileName:=("c:\proposals\" & company & "\" & company & ".doc")
MsgBox "A new company proposal for " & company & " has been created"
End Sub
If it's crashing on End Sub it's likely related to the destruction of objects. Make sure you manually destroy your objects prior to the code exiting. This will give you an idea of exactly which object is crashing the code.
I do not use two different MACROS when coding between applications. It is possible to tell Word (or excel) to run each other.
Place all of the code within only 1 macro in 1 application. For instance, excel does stuff and then opens word. So have excel tell word what to do directly.
Sub test()
Dim wdApp As New Word.Application
wdApp.Visible = True
wdApp.Documents.Add
wdApp.ActiveDocument.Paragraphs(1).Range.Text = "Hello World"
End Sub
By referencing the correct library (Microsoft Word 14.0 object library for 2010 and Microsoft Word 15.0 object library for 2013) you can can tell excel what to do within the word document as my example shows.
Generally, this is as easy as copy and pasting the code and then enclosing the part for word in a with statement:
with wdAPP
'All your word specific code here (might need to add a '.' before each command
end with
Another issue I found with trying to call macros from a different application is that it is hard to know if the macro exists on the other side. Maybe a user installed them incorrectly (my macros are distributed to ~300 people)
I want to update Powerpoint Graph 2010 from Excel 2010.
Code looks for the Objects and finds the range with name similar in powerpoint, it applies changes to the graph. Graph format should be same only data must be updated.
Code is as follow, it is not able to find charts, either able to update it.
Option Explicit
Private Const NAMED_RANGE_PREFIX = "Export_"
Private Const NAMED_RANGE_PREFIX_TEXT = "ExportText"
Private m_sLog As String
Private Sub CommandButton1_Click()
On Error GoTo Catch
Dim pptApp As PowerPoint.Application
Dim pptPresentation As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShape As PowerPoint.Shape
Dim mgrChart As Chart
Dim mgrDatasheet As Graph.DataSheet
Dim rngData As Excel.Range
Dim iRow As Long, iCol As Long
Dim sTag As String
Dim nFound As Long, nUpdated As Long
Dim nFoundText As Long, nUpdatedText As Long
Dim i As Integer
Dim fLog As frmLog
Dim Box1Status As VbMsgBoxResult
m_sLog = ""
'Prompt to Export
Box1Status = MsgBox("Export and Save to Powerpoint Template?" & Chr(13) & "Reminder: Please use a clean template for export and be sure to back up the template beforehand. " & Chr(13) & Chr(13) & "PLEASE SAVE ANY OTHER OPEN POWERPOINT DOCUMENTS AS ALL UNSAVED WORK WILL BE LOST!", vbQuestion + vbYesNo, "Confirm Export")
If Box1Status = vbNo Then Exit Sub
i = 1
UpdateStatus "Opening Powerpoint presentation '" & Range("fileloc")
Set pptApp = New PowerPoint.Application
pptApp.Activate
Set pptPresentation = pptApp.Presentations.Open(Range("fileloc"))
pptApp.WindowState = ppWindowMinimized
'Looks for (tagged) charts to update
UpdateStatus "Searching presentation for charts..."
For Each pptSlide In pptPresentation.Slides
For Each pptShape In pptSlide.Shapes
If pptShape.Type = msoEmbeddedOLEObject Then
If TypeOf pptShape.OLEFormat.Object Is Graph.Chart Then
nFound = nFound + 1
Set mgrChart = pptShape.OLEFormat.Object
Set mgrChart = pptShape.Chart
Set mgrDatasheet = mgrChart.Application.DataSheet
With mgrDatasheet
sTag = .Cells(1, 1)
If Left(sTag, 6) = "Export" Then UpdateStatus "Found chart on slide '" & pptSlide.SlideNumber & "' with tag '" & sTag & "'. Searching Excel workbook for same tag..."
Set rngData = RangeForChart(sTag)
If rngData Is Nothing Then
' This chart has no data in this Excel workbook
If Left(sTag, 6) <> "Export" Then
UpdateStatus "Found chart on slide '" & pptSlide.SlideNumber & "' with no tag, skipping"
Else
UpdateStatus "'" & sTag & "' does not exist in workbook, skipping."
End If
Else
' Update the PowerPoint chart with the Excel data
UpdateStatus "Found '" & sTag & "' at named range '" & rngData.Name & "'. Updating presentation..."
.Cells.ClearContents
For iRow = 0 To rngData.Rows.Count - 1
For iCol = 0 To rngData.Columns.Count - 1
.Cells(iRow + 1, iCol + 1) = rngData.Cells(iRow + 1, iCol + 1)
Next iCol
Next iRow
.Application.Update
UpdateStatus "Chart with tag '" & sTag & "' updated."
nUpdated = nUpdated + 1
End If
End With
Set mgrDatasheet = Nothing
mgrChart.Application.Quit
Set mgrChart = Nothing
End If
'End If
Next pptShape
i = i + 1
Next pptSlide
UpdateStatus "Finished searching presentation. Closing PowerPoint."
pptPresentation.Save
pptPresentation.Close
Set pptPresentation = Nothing
pptApp.Quit
Set pptApp = Nothing
UpdateStatus "Done. " & nFound & " charts found and " & nUpdated & " charts updated. " & nFoundText & " text boxes found and " & nUpdatedText & " text boxes updated."
Set fLog = New frmLog
fLog.Caption = "Update of Powerpoint Template Complete"
fLog.txtLog.Text = m_sLog
fLog.Show
Unload fLog
Set fLog = Nothing
Exit Sub
Catch:
MsgBox "An unexpected error occurred while updating: " & Err.Number & " " & Err.Description, vbCritical
ForceCleanup mgrChart, mgrDatasheet, pptPresentation, pptApp
End Sub
Private Property Get RangeForChart(sTag As String) As Range
Dim sChartTag As String
Dim iUpdate As Long
Dim NameList As Range
'Dim nRow As Range
Set NameList = Range("Name_List")
If Left(sTag, 6) <> "Export" Then Exit Property
'For Each nRow In NameList.Rows
Do While sChartTag <> sTag
iUpdate = iUpdate + 1
' This will error if there is no named range for "Export_", which means that sTag does not
' exist in the workbook so return nothing
On Error Resume Next
sChartTag = ActiveWorkbook.Names(NAMED_RANGE_PREFIX & NameList(iUpdate, 1).Value).RefersToRange.Cells(1, 1)
If Err.Number <> 0 Then
' Return nothing
Exit Property
End If
On Error GoTo 0
Loop
'Next nRow
Set RangeForChart = ActiveWorkbook.Names(NAMED_RANGE_PREFIX & NameList(iUpdate, 1).Value).RefersToRange
End Property
Private Property Get RangeForText(sTag As String) As Range
Dim sTextTag As String
Dim iUpdate As Long
If Left(sTag, 10) <> "ExportText" Then Exit Property
Do While sTextTag <> sTag
iUpdate = iUpdate + 1
' This will error if there is no named range for "ExportText" & iUpdate, which means that sTag does not
' exist in the workbook so return nothing
On Error Resume Next
sTextTag = NAMED_RANGE_PREFIX_TEXT & iUpdate
If Err.Number <> 0 Then
' Return nothing
Exit Property
End If
On Error GoTo 0
Loop
Set RangeForText = ActiveWorkbook.Names(NAMED_RANGE_PREFIX_TEXT & iUpdate).RefersToRange
End Property
Private Sub UpdateStatus(sMessage As String)
m_sLog = m_sLog & Now() & ": " & sMessage & vbNewLine
Application.StatusBar = Now() & ": " & sMessage
DoEvents
End Sub
Private Sub ForceCleanup(mgrChart As Graph.Chart, mgrDatasheet As Graph.DataSheet, pptPresentation As PowerPoint.Presentation, pptApp As PowerPoint.Application)
On Error Resume Next
mgrChart.Application.Quit
Set mgrChart = Nothing
mgrDatasheet.Application.Quit
Set mgrDatasheet = Nothing
pptPresentation.Close
Set pptPresentation = Nothing
pptApp.Quit
Set pptApp = Nothing
End Sub
I don't think you need a bunch of code for this.
Build the charts in Excel, copy them, go to PowerPoint, use Paste Special - Link. Change the data in Excel, and the Excel charts update. Then open the PowerPoint presentation, and if necessary, update links.
In the data sheet for your powerpoint graph, you can "link" the cells to your excel data file by typing in one of the cells (path and file name are made up here)
=c:\PPTXfiles\excelfiles[excelfiles.xlsx]sheetname'!a1
This will create a link that doesn't show up in the links section of powerpoint, but can be updated just by opening both files and double clicking on the chart to activate it.
Sometime the paste by link feature isn't feasible to use since the end user of the file wants to "break it up" and send out parts. That is not possible without the source excel file, since the end users want to be able to edit the chart or the data.
If you can do this and then copy and paste the data sheet by values in VBA, before sending to the enduser that would be fantastic.
Bam!
Sub UpdateLinks()
Dim ExcelFile
Dim exl As Object
Set exl = CreateObject("Excel.Application")
'Open a dialog box to promt for the new source file.
ExcelFile = exl.Application.GetOpenFilename(, , "Select Excel File")
Dim i As Integer
Dim k As Integer
'Go through every slide
For i = 1 To ActivePresentation.Slides.Count
With ActivePresentation.Slides(i)
'Go through every shape on every slide
For k = 1 To .Shapes.Count
'Turn of error checking s that it doesn 't crash if the current shape doesn't already have a link
On Error Resume Next
'Set the source to be the same as teh file chosen in the opening dialog box
.Shapes(k).LinkFormat.SourceFullName = ExcelFile
If .Shapes(k).LinkFormat.SourceFullName = ExcelFile Then
'If the change was successful then also set it to update automatically
.Shapes(k).LinkFormat.Update
End If
On Error GoTo 0
Next k
End With
Next i
End Sub