Paste charts from Excel to Word error - The Remote Server Machine does not exist (Error 462) - vba

I have a macro which carries out the following logic in VBA in excel:
Opens a word document
Loop through all the pre set bookmarks in the document
When a bookmark is found, loop through all the chart objects in a specific sheet, when the Chart Name matches the bookmark name, copy that into the word doc
I am running into Error 462 on the second run of the macro. I realise it's to do with not referencing an object properly but I cant seem to find where the culprit is.
My code looks like this:
Sub buildDocument()
'#### Initialise our variables
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim theWorksheet As Worksheet
Dim Chart As ChartObject
Dim wdBookmarksArray() As Variant
Dim counter1 As Integer
Dim counter2 As Integer
Dim noCharts As Integer
Dim counter4 As Integer
Dim PasteObect As Variant
Dim quarter As String
Dim sheetsArr As String
'#### Switch off update ####
Application.ScreenUpdating = False
'#### Create a new word doc; minimise; ####
Set wdApp = New Word.Application
With wdApp
.Visible = True
.WindowState = wdWindowStateMinimize
End With
On Error GoTo ErrorHandler
'#### Build a dialog box to find the
' correct word template file ####
Set wdDoc = wdApp.Documents.Open(openDialog())
counter2 = 1
counter3 = 1
For counter1 = 1 To wdDoc.Bookmarks.Count
'#### Export "New Issue Timing" graphs to
' word document ####
Call copyGraphs(newIssuesTiming, _
counter1, _
wdDoc, _
wdApp)
Next
ThisWorkbook.sheets(mainSheet).Select
Set wdApp = Nothing
Set wdDoc = Nothing
Exit Sub
ErrorExit:
wdDoc.Close
wdApp.Quit
Set wdApp = Nothing
Set wdDoc = Nothing
Exit Sub
ErrorHandler:
Dim error_report As ErrorControl
Set error_report = New ErrorControl
error_report.SetErrorDetail = Err.Description
error_report.SetErrorNumber = Err.Number
error_report.SetErrorSection = "BUILD_WORD_DOC"
If error_report.GenerateErrorReport Then
Resume ErrorExit
End If
Set error_report = Nothing
My copyGraphs looks like:
Sub copyGraphs(sheet As String, _
counter1 As Integer, _
wdDoc As Word.Document, _
wdApp As Word.Application)
Dim wdBookmarksArray() As Variant
Dim counter2 As Integer
Dim Chart As ChartObject
Dim theWorksheet As Worksheet
Dim noCharts As Integer
Dim counter4 As Integer
Dim PasteObect As Variant
Dim quarter As String
Dim sheetsArr As String
For Each Chart In ThisWorkbook.sheets(sheet).ChartObjects
If wdDoc.Bookmarks(counter1).name = Chart.name Then
ThisWorkbook.sheets(sheet).ChartObjects(Chart.name).Copy
wdApp.Selection.Goto What:=wdGoToBookmark, name:=wdDoc.Bookmarks(counter1).name
wdApp.Selection.PasteSpecial DataType:=wdPasteEnhancedMetafile
End If
Next
End Sub
The copyGraph Sub is in the same module as the sub that calls it.

Adding ByVal did in fact work, but required the excel sheet to be closed and reopened to clear all the objects from memory.
Credit #R3uK for the answer
The below code works:
Sub buildDocument()
'#### Initialise our variables
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim theWorksheet As Worksheet
Dim Chart As ChartObject
Dim wdBookmarksArray() As Variant
Dim counter1 As Integer
Dim counter2 As Integer
Dim noCharts As Integer
Dim counter4 As Integer
Dim PasteObect As Variant
Dim quarter As String
Dim sheetsArr As String
'#### Switch off update ####
Application.ScreenUpdating = False
'#### Create a new word doc; minimise; ####
Set wdApp = New Word.Application
With wdApp
.Visible = True
.WindowState = wdWindowStateMinimize
End With
On Error GoTo ErrorHandler
'#### Build a dialog box to find the
' correct word template file ####
Set wdDoc = wdApp.Documents.Open(openDialog())
counter2 = 1
counter3 = 1
For counter1 = 1 To wdDoc.Bookmarks.Count
'#### Export "New Issue Timing" graphs to
' word document ####
Call copyGraphs(newIssuesTiming, _
counter1, _
wdDoc, _
wdApp)
Next
ThisWorkbook.sheets(mainSheet).Select
wdDoc.Save
wdDoc.Close
wdApp.Quit
Set wdApp = Nothing
Set wdDoc = Nothing
Exit Sub
ErrorExit:
wdDoc.Close
wdApp.Quit
Set wdApp = Nothing
Set wdDoc = Nothing
Exit Sub
ErrorHandler:
Dim error_report As ErrorControl
Set error_report = New ErrorControl
error_report.SetErrorDetail = Err.Description
error_report.SetErrorNumber = Err.Number
error_report.SetErrorSection = "BUILD_WORD_DOC"
If error_report.GenerateErrorReport Then
Resume ErrorExit
End If
Set error_report = Nothing
End Sub
Routine to copy graphs :
Sub copyGraphs(ByVal sheet As String, _
ByVal counter1 As Integer, _
ByVal wdDoc As Word.Document, _
ByVal wdApp As Word.Application)
Dim wdBookmarksArray() As Variant
Dim counter2 As Integer
Dim Chart As ChartObject
Dim theWorksheet As Worksheet
Dim noCharts As Integer
Dim counter4 As Integer
Dim PasteObect As Variant
Dim quarter As String
Dim sheetsArr As String
For Each Chart In ThisWorkbook.sheets(sheet).ChartObjects
If wdDoc.Bookmarks(counter1).name = Chart.name Then
ThisWorkbook.sheets(sheet).ChartObjects(Chart.name).Copy
ThisWorkbook.sheets(sheet).ChartObjects(Chart.name).Copy
wdApp.Selection.Goto What:=wdGoToBookmark, name:=wdDoc.Bookmarks(counter1).name
wdApp.Selection.PasteSpecial DataType:=wdPasteEnhancedMetafile
End If
Next
End Sub

Related

vba "run-time error 1004: Method 'Paste' of object '_Worksheet' failed

I am trying to paste only from the non empty rows. The error is in line 6. If someone could help me I would really appreciate it because I am stucked with this and I don't kow how to fix it.
Public Sub read_truefalse()
Dim wApp As Word.Application
Dim wDoc As Word.Document
Dim path As String
path = Sheet5.Cells(3, 1).Value
Set wApp = CreateObject("Word.Application")
Set wDoc = wApp.Documents.Open(path, ReadOnly:=True)
Dim i As Long
i = 0
Dim wPara As Word.Paragraph
Dim last As Integer
...
Sheet 7.Activate
1 For Each wPara In wDoc.Paragraphs
2 If wPara.Range.Words.Count > 1 Then
3 last = wPara.Range.Words.Count
4 wPara.Range.Copy
5 Sheet7.Range("A1").Offset(i, 0).Activate
6 Sheet7.Paste
7 i = i + 1
...
Try this:
Public Sub read_truefalse()
Dim wApp As Word.Application
Dim wDoc As Word.Document, wPara As Word.Paragraph
Dim path As String
Dim i As Long, last As Long
path = Sheet5.Cells(3, 1).Value
Set wApp = CreateObject("Word.Application")
Set wDoc = wApp.Documents.Open(path, ReadOnly:=True)
For Each wPara In wDoc.Paragraphs
If wPara.Range.Words.Count > 1 Then
i = i + 1
last = wPara.Range.Words.Count '??
wPara.Range.Copy
With Sheet7
.Paste Destination:=.Cells(i, "A") 'no need to select to paste
End With
End If
Next wPara
'clean up...
wDoc.Close False
wApp.Quit
End Sub

Copy range in Word avoiding clipboard

I have the code below to copy an array of tables in Word to Excel. The volume of data being copied gives memory problems, so I would like to avoid the clipboard - i.e. avoid using Range.Copy
Word does not support Range.Value and I have not been able to get Range(x) = Range(y) to work.
Any suggestions for a way to avoid the clipboard? Word formatting can be junked.
Sub ImportWordTableArray()
Dim WordApp As Object
Dim WordDoc As Object
Dim arrFileList As Variant, FileName As Variant
Dim tableNo As Integer 'table number in Word
Dim tableStart As Integer
Dim tableTot As Integer
Dim Target As Range
On Error Resume Next
arrFileList = Application.GetOpenFilename("Word files (*.doc; *.docx),*.doc;*.docx", 2, _
"Browse for file containing table to be imported", , True)
If Not IsArray(arrFileList) Then Exit Sub
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
Worksheets("Test").Range("A:AZ").ClearContents
Set Target = Worksheets("Test").Range("A1")
For Each FileName In arrFileList
Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True)
With WordDoc
'For array
Dim tables() As Variant
Dim tableCounter As Long
tableNo = WordDoc.tables.Count
tableTot = WordDoc.tables.Count
If tableNo = 0 Then
MsgBox WordDoc.Name & "Contains no tables", vbExclamation, "Import Word Table"
End If
tables = Array(1, 3, 5) '<- define array manually here if not using InputBox
For tableCounter = LBound(tables) To UBound(tables)
With .tables(tables(tableCounter))
.Range.Copy
Target.Activate
'Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False '<- memory problems!
'Or
ActiveSheet.Paste '<- pastes with formatting
Set Target = Target.Offset(.Rows.Count + 2, 0)
End With
Next tableCounter
.Close False
End With
Next FileName
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub
You may need to tweak the code below to get it to do exactly what you want (Excel is not something I use often) as the calculation of ranges is a bit wonky, but it will transfer text from word to excel without cutting and pasting
Option Explicit
' This code is based on it being in an Excel VBA Module with the reference
' to the Microsoft Word Object XX.X Object Library (Tools.References)
' enabled so that we get intellisense for Word objects
Public Enum ImportError
NoTablesInDocument
End Enum
Sub ImportWordTableArray()
Dim myFileList As Variant
If Not TryGetFileList(myFileList) Then Exit Sub
Dim myWdApp As Word.Application
Set myWdApp = New Word.Application
myWdApp.Visible = True
If Application.ReferenceStyle = xlA1 Then Application.ReferenceStyle = xlR1C1
ThisWorkbook.Worksheets("Test").Range("A:AZ").ClearContents
Dim myFileName As Variant
For Each myFileName In myFileList
Dim myDoc As Word.Document
If TryGetWordDoc(myFileName, myWdApp, myDoc) Then
CopyDocTablesToExcel myDoc, ThisWorkbook.Worksheets("Test")
End If
Next
If Application.ReferenceStyle = xlR1C1 Then Application.ReferenceStyle = xlA1
End Sub
Public Sub CopyDocTablesToExcel(ByVal ipDoc As Word.Document, ByVal ipWs As Excel.Worksheet)
If ipDoc.Tables.Count = 0 Then
Report ipDoc.Name, ImportError.NoTablesInDocument
Exit Sub
End If
Dim myTable As Variant
Dim Target As Excel.Range
For Each myTable In ipDoc.Tables
' This code assumes that the Word table is 'uniform'
Dim myCols As Long
myCols = myTable.Range.Tables.Item(1).Range.Columns.Count
Dim myRows As Long
myRows = myTable.Range.Tables.Item(1).Range.Rows.Count
Dim myTLCell As Excel.Range
Dim myBRCell As Excel.Range
If Target Is Nothing Then
Set myTLCell = ipWs.Cells(1, 1)
Set myBRCell = ipWs.Cells(myCols, myRows)
Else
Set myTLCell = ipWs.Cells(1, Target.Cells.SpecialCells(xlCellTypeLastCell).Row + 2)
Set myBRCell = ipWs.Cells(myCols, Target.Cells.SpecialCells(xlCellTypeLastCell).Row + 2 + myRows)
End If
Set Target = ipWs.Range(myTLCell, myBRCell)
Target = GetTableArray(myTable)
Next
End Sub
Public Function GetTableArray(ByVal ipTable As Word.Table) As Variant
Dim myArray As Variant
Dim myRow As Long
Dim myCol As Long
ReDim myArray(1 To ipTable.Range.Tables.Item(1).Range.Rows.Count, 1 To ipTable.Range.Tables.Item(1).Range.Columns.Count)
For myRow = 1 To UBound(myArray, 1) - 1
For myCol = 1 To UBound(myArray, 2) - 1
Dim myText As String
myText = ipTable.Cell(myRow, myCol).Range.Text
myArray(myRow, myCol) = VBA.Left$(myText, Len(myText) - 2)
Next
Next
GetTableArray = myArray
End Function
Public Function TryGetFileList(ByRef opFileList As Variant) As Boolean
On Error Resume Next
opFileList = _
Application.GetOpenFilename _
( _
"Word files (*.doc; *.docx),*.doc;*.docx", _
2, _
"Browse for file containing table to be imported", _
, _
True _
)
TryGetFileList = (Err.Number = 0) And IsArray(opFileList)
On Error GoTo 0
End Function
Public Function TryGetWordDoc _
( _
ByVal ipName As String, _
ByRef ipWdApp As Word.Application, _
ByRef opDoc As Word.Document _
) As Boolean
On Error Resume Next
Set opDoc = ipWdApp.Documents.Open(ipName, ReadOnly:=True)
TryGetWordDoc = (Err.Number = 0) And (Not opDoc Is Nothing)
On Error GoTo 0
End Function
Public Function Report(ByVal ipString As String, ByVal ipError As ImportError)
Select Case ipError
Case NoTablesInDocument
MsgBox ipString & " Contains no tables", vbExclamation, "Import Word Table"
Case Else
End Select
End Function
For tableCounter ... Next code modified below to extract data directly rather than using copy and paste.
Sub ImportWordTablesArray()
Dim WordApp As Object
Dim WordDoc As Object
Dim arrFileList As Variant, Filename As Variant
Dim tableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
Dim resultRow As Long
Dim tables() As Variant
Dim tableCounter As Long
On Error Resume Next
arrFileList = Application.GetOpenFilename("Word files (*.doc; *.docx),*.doc;*.docx", 2, _
"Browse for file containing table to be imported", , True)
If Not IsArray(arrFileList) Then Exit Sub '<-user cancelled import file browser
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
Worksheets("Test").Range("A:E").Clear '<-ClearContents to clear only text
For Each Filename In arrFileList
Set WordDoc = WordApp.Documents.Open(Filename, ReadOnly:=True)
With WordDoc
If WordDoc.ProtectionType <> wdNoProtection Then
WordDoc.Unprotect Password:=SREPedit
End If
tableNo = WordDoc.tables.Count
If tableNo = 0 Then
MsgBox WordDoc.Name & "Contains no tables", vbExclamation, "Import Word Table"
End If
tables = Array(1, 2, 8) '<- Select tables for data extraction
For tableCounter = LBound(tables) To UBound(tables)
With .tables(tables(tableCounter))
For iRow = 1 To .Rows.Count
For iCol = 1 To .Columns.Count
Cells(resultRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
Next iCol
resultRow = resultRow + 1
Next iRow
End With
resultRow = resultRow + 1
Next tableCounter
.Close False
End With
Next Filename
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub

Generating a Microsoft Word Report from Excel—Application Waiting for OLE Action? (VBA)

I'm trying to write a macro that will generate a Microsoft Word 'report' from an Excel file. I want for the macro to navigate to bookmarks in a Word template for the report, and insert at each certain content or a chart from the native Excel file. The macro works when running in piecemeal, but altogether fails to execute, with Excel repeating over and over that "[It] is waiting for another application to complete an OLE action."
To clarify also, the macro first clears a certain 'data dump' region in the workbook (its native file) and repopulates it with new data from a specified file. This file (its location path) and the various 'target row' and 'identifier' variables you see in the code are inputted by the user to a sort of interface (just a worksheet in the native workbook), where each is labeled manually as a (named) range to be easily fed into to be used by the code. The macro then creates the report by going through the different sheets of the workbook, copying certain content, and turning to Word to paste the copied content at template locations indicated by bookmarks.
I'm completely perplexed by the 'OLE error'. Any ideas about this/the code otherwise? Please share. Thanks for your help!
Sub GenerateReport()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim myWorkbook As Excel.Workbook
Set myWorkbook = ThisWorkbook
Dim myWorksheet As Excel.Worksheet
Set myWorksheet = myWorkbook.Sheets("Sheet1")
Dim myWorksheet2 As Excel.Worksheet
Set myWorksheet2 = myWorkbook.Sheets("Sheet2")
Dim myWorksheet3 As Excel.Worksheet
Set myWorksheet3 = myWorkbook.Sheets("Sheet3")
Dim FileName As String
FileName = myWorksheet.Range("FileName")
Dim FilePath As String
FilePath = myWorksheet.Range("FilePath")
Dim TargetSheetName As String
TargetSheetName = myWorksheet.Range("TargetSheetName")
Dim PasteSheetName As String
PasteSheetName = myWorksheet.Range("PasteSheetName")
Dim Identifier As String
Identifier = myWorksheet.Range("Identifier")
Dim Identifier2 As String
Identifier2 = myWorksheet.Range("Identifier2")
Dim TargetRow As String
TargetRow = myWorksheet.Range("TargetRow")
Dim TargetRow2 As String
TargetRow2 = myWorksheet.Range("TargetRow2")
Dim PasteIdentifier As String
PasteIdentifier = myWorksheet.Range("PasteIdentifier")
Dim PasteIdentifier2 As String
PasteIdentifier2 = myWorksheet.Range("PasteIdentifier2")
Dim PasteTargetRow As String
PasteTargetRow = myWorksheet.Range("PasteTargetRow")
Dim PasteTargetRow2 As String
PasteTargetRow2 = myWorksheet.Range("PasteTargetRow2")
Dim Text As String
Text = myWorksheet.Range("Text")
Dim Text2 As String
Text2 = myWorksheet.Range("Text2")
Dim Text3 As String
Text3 = myWorksheet.Range("Text3")
Dim ReportTemplateFilePath As String
ReportTemplateFilePath = myWorksheet.Range("ReportTemplateFilePath")
Dim ReportTemplateFileName As String
ReportTemplateFileName = myWorksheet.Range("ReportTemplateFileName")
Dim SaveToLocation As String
SaveToLocation = myWorksheet.Range("SaveToLocation")
Dim SourceTargetSheet As Excel.Worksheet
Set SourceTargetSheet = myWorkbook.Sheets(PasteSheetName)
Dim TargetWorkbook As Excel.Workbook
Set TargetWorkbook = Workbooks.Open(FilePath)
Dim TargetSheet As Excel.Worksheet
Set TargetSheet = TargetWorkbook.Sheets(TargetSheetName)
'Clear old info
Dim UpperLeftHandCornerOfClear As String
UpperLeftHandCornerOfClear = "A" & PasteTargetRow
Dim LowerRightHandCornerOfClear As String
LowerRightHandCornerOfClear = "XFD" & PasteTargetRow2
SourceTargetSheet.Range(UpperLeftHandCornerOfClear, LowerRightHandCornerOfClear).ClearContents
'Copy new info for pasting
Dim StartingColumnAsRange As Range
Set StartingColumnAsRange = TargetSheet.Cells.Find(Identifier, LookIn:=xlValues, LookAt:=xlPart)
If Not StartingColumnAsRange Is Nothing Then
Dim StartingColumn As String
StartingColumn = Split(StartingColumnAsRange.Address, "$")(1)
End If
Dim EndingColumnAsRange As Range
Set EndingColumnAsRange = TargetSheet.Cells.Find(Identifier2, LookIn:=xlValues, LookAt:=xlPart)
If Not EndingColumnAsRange Is Nothing Then
Dim EndingColumn As String
EndingColumn = Split(EndingColumnAsRange.Address, "$")(1)
End If
Dim UpperLeftHandCornerOfCopy As String
UpperLeftHandCornerOfCopy = StartingColumn & TargetRow
Dim LowerRightHandCornerOfCopy As String
LowerRightHandCornerOfCopy = EndingColumn & TargetRow2
TargetSheet.Range(UpperLeftHandCornerOfCopy, LowerRightHandCornerOfCopy).Copy
Dim PastePasteTarget As String
PastePasteTarget = "A" & PasteTargetRow
SourceTargetSheet.Range(PastePasteTarget).PasteSpecial Paste:=xlPasteValues
'Create a Microsoft Word object (instance of Word to control)
Dim WordApplication As Word.Application
Set WordApplication = CreateObject("Word.Application")
'Error handle if Microsoft Word is open
On Error Resume Next
Set WordApplication = GetObject(class:="Word.Application")
Err.Clear
If WordApplication Is Nothing Then
Set WordApplication = CreateObject(class:="Word.Application")
End If
On Error GoTo 0
'Error handle if report template is specifically already open
On Error Resume Next
Application.DisplayAlerts = False
Documents(ReportTemplateFileName).Close SaveChanges:=wdDoNotSaveChanges
On Error GoTo 0
Application.DisplayAlerts = True
Dim WordDocument As Word.Document
Set WordDocument = WordApplication.Documents.Open(ReportTemplateFilePath)
'Content from 'myWorksheet'
With WordDocument
.Bookmarks("Bookmark1").Range.Text = myWorksheet.Range("Text1")
.Bookmarks("Bookmark2").Range.Text = myWorksheet.Range("Text2")
.Bookmarks("Bookmark3").Range.Text = myWorksheet.Range("Text3")
.Bookmarks("Bookmark4").Range.Text = myWorksheet.Range("Text4")
End With
'Content from 'myWorksheet2'
With WordDocument
.Bookmarks("Bookmark5").Range.Text = myWorksheet2.Range("Text5")
.Bookmarks("Bookmark6").Range.Text = myWorksheet2.Range("Text6")
.Bookmarks("Bookmark7").Range.Text = myWorksheet2.Range("Text7")
.Bookmarks("Bookmark8").Range.Text = myWorksheet2.Range("Text8")
.Bookmarks("Bookmark9").Range.Text = myWorksheet2.Range("Text9")
.Bookmarks("Bookmark10").Range.Text = myWorksheet3.Range("Text10")
End With
'Chart (alone on worksheet)
WordApplication.Selection.Goto What:=wdGoToBookmark, Name:="Chart1"
ThisWorkbook.Sheets("Chart 1 Worksheet Name").ChartObjects(1).Copy
WordApplication.Selection.Paste
WordApplication.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
'Two charts grouped together
WordApplication.Selection.Goto What:=wdGoToBookmark, Name:="Chart2"
ThisWorkbook.Sheets("Chart 2 Worksheet Name").ChartObjects(1).Copy
WordApplication.Selection.Paste
WordApplication.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
With WordDocument
.SaveAs FileName:=SaveToLocation & " " & Text3, _
FileFormat:=wdFormatDocumentDefault
.Close
End With
WordApplication.Quit
Set WordApplication = Nothing
Set WordDocument = Nothing
Application.ScreenUpdating = True
'Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
myWorksheet.Activate
MsgBox "Report successfully generated.", vbInformation, "Completed!"
End Sub
Try modifying your Word application creation script - this is all you need:
On Error Resume Next
Set WordApplication = GetObject(class:="Word.Application")
On Error GoTo 0
If WordApplication Is Nothing Then
Set WordApplication = CreateObject(class:="Word.Application")
End If
It may be that Word is waiting for some input from you but you're not seeing it because you didn't make the instance visible, so try also adding:
WordApplication.Visible = True

Export queries from Access-Form to Excel with Loop in VBA

I want to Export large data stock from Access to Excel. I'm doing that with a form.
My code with "DoCmd.TransferSpreadsheet acExport..." works normally, but the program breaks off because of the large data stock.
Perhaps with queries I can solve this Problem, or what do you think?
I am thankful for each tip! =)
you can you use below code: this will copy the datesheet view in your form and copy paste it in to one excel file .For this you just drag one sub form control from tool box in to your form and set the property of this sub form's source data as your query name and replace the sub form name in the code
Private Sub Command48_Click()
On Error GoTo Command13_Click_Err
Me.subformName.SetFocus
'DoCmd.GoToControl "Policy Ref"
DoCmd.RunCommand acCmdSelectAllRecords
DoCmd.RunCommand acCmdCopy
Dim xlapp As Excel.Application
Set xlapp = CreateObject("Excel.Application")
With xlapp
.Workbooks.Add
.ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:= _
False
.Cells.Select
.Cells.EntireColumn.AutoFit
.Visible = True
.Range("a1").Select
End With
Command13_Click_Exit:
Exit Sub
Command13_Click_Err:
MsgBox Error$
Resume Command13_Click_Exit
End sub
'=======================
you can you use below code: this will copy the datesheet view in your form and copy paste it in to one excel file .For this you just drag one sub form control from tool box in to your form and set the property of this sub form's source data as your query name and replace the sub form name in the code
Private Sub Command48_Click()
On Error GoTo Command13_Click_Err
Me.subformName.SetFocus
'DoCmd.GoToControl "Policy Ref"
DoCmd.RunCommand acCmdSelectAllRecords
DoCmd.RunCommand acCmdCopy
Dim xlapp As Excel.Application
Set xlapp = CreateObject("Excel.Application")
With xlapp
.Workbooks.Add
.ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:= _
False
.Cells.Select
.Cells.EntireColumn.AutoFit
.Visible = True
.Range("a1").Select
End With
Command13_Click_Exit:
Exit Sub
Command13_Click_Err:
MsgBox Error$
Resume Command13_Click_Exit
End sub
'''PPT
Sub pptExoprort()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim slideNum As Integer
Dim chartName As String
Dim tableName As String
Dim PPTCount As Integer
Dim PPSlideCount As Long
Dim oPPTShape As PowerPoint.Shape
Dim ShpNm As String
Dim ShtNm As String
Dim NewSlide As String
Dim myChart As PowerPoint.Chart
Dim wb As Workbook
Dim rngOp As Range
Dim ro As Range
Dim p As Integer
Dim v, v1, v2, v3, Vtot, VcaGr
Dim ws As Worksheet
Dim ch
Dim w As Worksheet
Dim x, pArr
Dim rN As String
Dim rt As String
Dim ax
Dim yTbN As String
'Call InitializeGlobal
''start year offset
prodSel = shtSet.Range("rSelProd")
x = shtSet.Range("rngMap").Value
pArr = fretPrVal(x, prodSel)
TY = 11 'number of years in chart
ThisWorkbook.Activate
Set w = ActiveSheet
Set PPApp = GetObject("", "Powerpoint.Application") '******************
PPTCount = PPApp.Presentations.Count
If PPTCount = 0 Then
MsgBox ("Please open a PPT to export the Charts!")
Exit Sub
End If
Set PPPres = PPApp.ActivePresentation '******************
For j = 0 To UBound(pArr)
If j = 0 Then
rN = "janport"
slideNum = 3
yTbN = "runport"
Else
rN = "janprod" & j
slideNum = 3 + j
yTbN = "runprod" & j
End If
chartName = "chtSalesPort"
Set PPSlide = PPPres.Slides(slideNum) '**************
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
Set myChart = PPSlide.Shapes(chartName).Chart '******************
myChart.ChartData.Activate '********************
Set wb = myChart.ChartData.Workbook '***********
Set ws = wb.Worksheets(1) '**************
Set rngOp = w.Range(rN).Offset(0, 1).Resize(12, 6)
Set ro = rngOp
' v1 = ro.Offset(1, 22).Resize(Lc, 1)
'ws.ListObjects("Table1").Resize Range("$A$1:$B$" & Ty + 1)
'ws.ListObjects("Table1").Resize Range("$A$1:$" & Chr(Lc + 1 + 64) & "$" & Ty + 1)
ws.Range("B2:g13").ClearContents '***********
rngOp.Copy '**********
ws.Range("B2:g13").PasteSpecial xlPasteValues '******************
End Sub
Sub Picture62_Click()
Dim charNamel As String
Dim leftm As Integer
Dim toptm As Integer
charNamel = "Chart 1"
leftm = 35
toptm = 180
Call chartposition(leftm, toptm, charNamel)
End Sub
Sub chartposition(leftm, toptm, charNamel)
ActiveSheet.ChartObjects(charNamel).Activate
'First we declare the variables we will be using
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject
Dim activslidenumber As Integer
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Let's create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
' If newPowerPoint.Presentations.Count = 0 Then
' newPowerPoint.Presentations.Add
' End If
'Show the PowerPoint
newPowerPoint.Visible = True
On Error GoTo endd:
activslidenumber = Str(GetActiveSlide(newPowerPoint.ActiveWindow).SlideIndex)
Set activeSlide = newPowerPoint.ActivePresentation.Slides(activslidenumber)
ActiveChart.ChartArea.Copy
On Error GoTo endddd:
activeSlide.Shapes.PasteSpecial(DataType:=ppPasteDefault).Select
'activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
'activeSlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, DisplayAsIcon:=msoFalse).Select
endddd:
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = leftm
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = toptm
GoTo enddddd:
endd:
MsgBox ("Please keep your PPT file opened")
enddddd:
End Sub

VBA PowerPoint Write to Excel on Slide Change in Slideshow

I am attempting to log (1. what slide and 2. the time) to a spreadsheet each time a slide is viewed in presentation mode. I don't want to have the spreadsheet open when I do this and I want it to save automatically. I've been screwing around with it for a few hours now, and I've had varying success. I can't seem to get it to work as intended.
Here's the code I've crammed together so far:
Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim strSheet As String
Dim strPath As String
Dim curentSlide As Integer
Dim timez As Date
Dim z As Integer
strSheet = "test.xlsx"
strPath = "C:\PPToutput\"
strSheet = strPath & strSheet
Dim counter As Integer
counter = 0
counter = counter + 1
currentslide = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
timez = Now()
If Not IsNull(appExcel) And counter < 2 Then
Set appExcel = CreateObject("Excel.Application")
appExcel.Application.DisplayAlerts = False
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
End If
appExcel.Application.Visible = True
Range("A" & Rows.Count).End(xlUp).Offset(1).Value = "Slide " & currentslide
Range("B" & Rows.Count).End(xlUp).Offset(1).Value = timez
wks.Columns.AutoFit
wkb.SaveAs
Set appExcel = Nothing
appExcel.Workbooks.Close
appExcel.Quit
Set appExcel = Nothing
End Sub
I haven't tried the code out, but something I noticed is that this line:
appExcel.Application.Visible = False
comes after the excel program does stuff. I would imagine the workbook opening would be visible because that happens before this line.
Also, I don't see where you're telling the OnSlideShowPageChange sub anything about the workbook you created in the SlideShowBegin sub. You're telling it to do something with a range, which is not the one you declared earlier. So, it thinks you're talking about some range in the powerpoint. Do powerpoints even have ranges?
The other mistake is that you set all of your public declarations to nothing. Once you try to call them again, you're calling nothing. It's still a good idea to do that in your error handler, but not as a normal part of the process.
Look at the [untested] changes I made and see if they make sense:
Public appExcel As Excel.Application
Public wkb As Excel.Workbook
Public wks As Excel.Worksheet
Public rng As Excel.Range
Public strSheet As String
Public strPath As String
Public intRowCounter As Integer
Public intColumnCounter As Integer
Public itm As Object
Sub SlideShowBegin()
On Error GoTo ErrHandler
strSheet = "test.xlsx"
strPath = "C:\PPToutput\"
strSheet = strPath & strSheet
Debug.Print strSheet
'Select export folder
Dim curentSlide As Integer
Dim timez As Date
Dim z As Integer
Dim placeholder1 As String
Dim placeholder2 As String
currentslide = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
timez = Now()
Set appExcel = CreateObject("Excel.Application")
appExcel.Application.Visible = False
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
wks.Range("A1").Value = "Current Slide"
wks.Range("B1").Value = "Time"
Exit Sub
ErrHandler:
If Err.Number = 1004 Then
MsgBox strSheet & " doesn't exist", vbOKOnly, _
"Error"
Else
MsgBox Err.Number & "; Description: ", vbOKOnly, _
"Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub
Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
Dim curentSlide As Integer
Dim timez As Date
Dim z As Integer
Dim placeholder1 As String
Dim placeholder2 As String
currentslide = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
timez = Now()
wks.Range("A" & Rows.Count).End(xlUp).Offset(1).Value = "Slide " & currentslide
wks.Range("B" & Rows.Count).End(xlUp).Offset(1).Value = timez
wks.Columns.AutoFit
wkb.Save
If SSW.View.CurrentShowPosition = _
SSW.Presentation.SlideShowSettings.EndingSlide Then
wkb.Save
wkb.Close
End If
End Sub
Sub SlideShowEnd()
wkb.Save
wkb.Close
End Sub
I rearranged your code a bit so that the initialization only occurs once during the slide show. I added another procedure to close Excel once the slide show has ended.
Private appExcel As Excel.Application
Private wkb As Excel.Workbook
Private wks As Excel.Worksheet
Private counter As Integer
Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
' initialization
Dim strSheet As String
Dim strPath As String
strSheet = "test.xlsx"
strPath = "C:\PPToutput\"
strSheet = strPath & strSheet
Debug.Print strSheet, appExcel Is Nothing
If appExcel Is Nothing Then
Set appExcel = CreateObject("Excel.Application")
appExcel.Application.DisplayAlerts = False
appExcel.WindowState = xlMinimized
appExcel.Visible = True
Set wkb = appExcel.Workbooks.Open(strSheet)
Set wks = wkb.Sheets(1)
counter = wks.UsedRange.Rows.Count - 1
End If
' make log entry
Dim currentSlide As Integer
currentSlide = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
counter = counter + 1
wks.Range("A" & counter).Value = "Slide " & currentSlide
wks.Range("B" & counter).Value = Now()
End Sub
Sub OnSlideShowTerminate(ByVal Wn As SlideShowWindow)
If Not appExcel Is Nothing Then
wks.Columns.AutoFit
appExcel.WindowState = xlNormal
wkb.Close True
appExcel.Quit
End If
Set appExcel = Nothing
End Sub
If it were my code, I'd also factor out the initialization code and put it in its own procedure so that the OnSlideShowPageChange procedure focused on the logging of the slide changes.