如何将 PowerPoint 中的附加值写入已打开的 Excel 文件？

Question

我在 PowerPoint 中有一个宏，可以更改 Excel 工作表中的值：

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

每次我通过按按钮激活 PowerPoint 中的宏时，Excel 文件都会再次打开，因此如果按三次，我会打开三个同名的文件。我只想打开一次。

Answer 1

这应该按照您想要的方式工作：

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

Answer 2

由于您希望（可能）重复写入 Excel 文件，因此您必须创建并（重新）附加到单个 Excel 应用程序，然后打开并（重新）附加到单个 Excel 文件。下面的示例代码展示了如何做到这一点：

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