Macro to write value from Powerpoint to Excel-CodePudding

I have a macro in PowerPoint that changes a value in an excel sheet:

Sub Hello()
Dim xlApp As Object
Dim xlWorkBook As Object

Set xlApp = CreateObject("Excel.Application")

xlApp.Visible = True
Set xlWorkBook = xlApp.Workbooks.Open("TEST.xlsx", True, False)
xlWorkBook.sheets(1).Range("A1").Value = "Hello"

Set xlApp = Nothing
Set xlWorkBook = Nothing
End Sub

The issue is: every time I activate the macro in powerpoint by pressing a button the excel file is opened again, so if I push 3 times I have 3 files with the same name open. How can I avoid this? I want to open it only 1 time.

Appreciate your help

CodePudding user response：

Since you want to (possibly) repeatedly write to an Excel file, you'll have to create and (re)attach to a single Excel application and open and (re)attach to a single Excel file. The example code below shows how this can be done:

Option Explicit

Sub test()
    WriteToWB "hello", CellAddr:="A1"
    WriteToWB "goodbye", CellAddr:="B1", CloseXlFile:=True
End Sub

Sub WriteToWB(ByVal NewValue As Variant, _
              ByVal CellAddr As String, _
              Optional CloseXlFile As Boolean = False)
    Dim xlFile As Excel.Workbook
    Set xlFile = AttachToExcelFile("C:\Temp\Book1.xlsx")
    
    Dim xlSheet As Excel.Worksheet
    Set xlSheet = xlFile.Sheets("Sheet1")
    
    xlSheet.Range(CellAddr).Value = NewValue
    
    If CloseXlFile Then
        xlFile.Close SaveChanges:=True
        QuitExcelApplication
    End If
End Sub

Public Function AttachToExcelFile(ByVal xlFilename As String) As Excel.Workbook
    Dim xlApp As Excel.Application
    Set xlApp = AttachToExcelApplication
    xlApp.Visible = True
    
    '--- this will open the workbook anew, or attach
    '    to the currently open workbook (as long as you
    '    don't close it)
    Dim xlWB As Excel.Workbook
    Set xlWB = xlApp.Workbooks.Open(Filename:=xlFilename, _
                                    ReadOnly:=False)
    Set AttachToExcelFile = xlWB
End Function

Public Sub QuitExcelApplication()
    Dim xlApp As Excel.Application
    Set xlApp = AttachToExcelApplication
    xlApp.Quit
End Sub

Public Function AttachToExcelApplication() As Excel.Application
    '--- finds an existing and running instance of MS Excel, or starts
    '    the application if one is not already running
    Dim xlApp As Excel.Application
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err > 0 Then
        '--- we have to start one
        '    an exception will be raised if the application is not installed
        Set xlApp = CreateObject("Excel.Application")
    End If
    Set AttachToExcelApplication = xlApp
End Function

CodePudding user response：

This should work as you want it to:

Sub Hello()
Dim xlApp As Object
Dim xlWorkBook As Object

Set xlApp = CreateObject("Excel.Application")

xlApp.Visible = True
Set xlWorkBook = xlApp.Workbooks.Open("c:\temp\TEST.xlsx", True, False)
xlWorkBook.sheets(1).Range("A1").Value = "Hello"

' save the file, or there's not much point to this
xlWorkBook.Save
' close the workbook
xlWorkBook.Close
' quit Excel
xlApp.Quit

' Now that Excel has quit, it doesn't really
' matter, but I've swapped these two.
Set xlWorkBook = Nothing
Set xlApp = Nothing

End Sub