Enable macro on a single workbook - excel

So, I'm working on an automation project and have stumbled on a roadblock because I can't call anything on a downloaded Excel file.
When I try opening the Excel file manually, its VB Editor is disabled... All other opened Excel files have it enabled.
I'm using below for downloading/opening the said Excel (XLSX) file.
Sub GetLogins()
Application.ScreenUpdating = False
NavSheet.Unprotect [pw]
Dim LoginWkbk As Workbook, LoginWksht As Worksheet
Dim WinHTTPRequest As Object, ADOStream As Object
Dim URL As String
Dim FileRev As Long, LastRow As Long, x As Long
Dim ts As Double
ts = Timer
FileRev = [Revision] ' The current logins file revision
FileRev = FileRev + 1 ' Check for the next revision. Hah!
TryAgain:
If Password = "" Then AcctLoginsForm.Show ' Password not (yet?) supplied
' Second line of security.
If Username = "" Or Password = "" Then
' This checks if the user provided the complete information required.
' If they didn't we would clear the admin logins sheet of any information that was in there.
Call ClearAcctsSheet
MsgBox "Insufficient information submitted.", vbOKOnly, "Window_Title"
GoTo ExitSub
End If
' The logins file URL
URL = "https://mysecreturl" & FileRev & ".xlsx"
Set WinHTTPRequest = CreateObject("Microsoft.XMLHTTP")
With WinHTTPRequest
' "GET" command with username and password
.Open "GET", URL, False, Username, Password
.Send
Select Case .Status
Case 401
' Incorrect credentials.
If MsgBox("Incorrect Username/Password supplied. Try again?", vbYesNo, "Window_Title") = vbYes Then
Call ClearAcctsSheet
Password = ""
GoTo TryAgain
Else
GoTo ExitSub
End If
Case 404
' The next revision is not yet uploaded, so we set to download the previous revision
FileRev = FileRev - 1
GoTo TryAgain
Case 200
' Set the "Revision" named range to the current file revision
[Revision] = FileRev
End Select
Set ADOStream = CreateObject("ADODB.Stream")
ADOStream.Open
ADOStream.Type = 1
ADOStream.Write .ResponseBody
ADOStream.SaveToFile Environ$("temp") & "\logins.xlsx", 2 ' Save the file in the temp file overwriting if the file exists
ADOStream.Close
End With
' Need to clear out the Accounts Sheet fields before populating it with the new credentials
AcctsSheet.Range("A:C").ClearContents
Set LoginWkbk = Workbooks.Open(Environ$("temp") & "\logins.xlsx")
Set LoginWksht = LoginWkbk.Sheets(1)
LastRow = LoginWksht.Cells(Rows.Count, 1).End(xlUp).Row ' Last row. Duh.
For x = 1 To LastRow
' Copy-pasting the information from the logins file crashes Excel, hence this for-loop.
AcctsSheet.Range("A" & x).Value = LoginWksht.Range("A" & x).Value
AcctsSheet.Range("B" & x).Value = LoginWksht.Range("G" & x).Value
AcctsSheet.Range("C" & x).Value = LoginWksht.Range("H" & x).Value
Application.StatusBar = "Extraction complete. Time elapsed: " & Round(Timer - ts, 2)
If LoginWksht.Range("A" & x).Value = "" Then
Exit For
End If
Next x
LoginWkbk.Close False ' Close the logins file
Kill Environ$("temp") & "\logins.xlsx" ' Delete the logins file
[DateToday] = Format(Now, "m/d/yyyy") ' Set the "DateToday" named range to the current day.
ExitSub:
NavSheet.Protect [pw]
NavSheet.Activate
ThisWorkbook.Save
SetToNothing WinHTTPRequest, ADOStream, LoginWkbk, LoginWksht
Application.ScreenUpdating = True
End Sub
I can open the Excel file with Workbooks.Open, but the opened XLSX file is not listed in the VBAProject window so I can't call anything on the sheet.
Has anyone encountered this here? Can we force-enable the macro settings on a single workbook?

A .xlsx file cannot have macros. In my test, the VB editor is not disabled, there are just no macros in the file to show. If you have macros enabled in Excel settings, then the workbook may still need to be in a Trusted Location for Excel to allow macros to run.

Related

Excel crashing randomly when running macro

I'm having an issue with the following code, that is supposed to sequentially open 〜100 csv files, check for a value in a cell (validation, if it is file with correct structure), copy single line of data and paste it into ThisWorkbook.Worksheets("2 CSV").Range("B" & row_number).
This solution worked for two years until this month. Now the whole Excel crashes randomly on any file without any error message. Sometimes it manages to loop through 20 files, sometimes 5.
The weirdest thing is, that I can loop manually using F8 through the whole thing without any problem.
The macro:
Sub b_load_csv()
Dim appStatus As Variant
Dim folder_path As String 'folder path to where CSVs are stored
Dim file_name As String 'file name of current CSV file
Dim row_number As Integer 'row number in target sheet
Dim source_sheet_name As String 'name of the source sheet of the CSV = CSV file name
Dim wb_src As Workbook 'variable for opened CSV source workbook
Dim sht_src As Worksheet 'variable for opened CSV source sheet
Dim sht_csv As Worksheet 'variable for target sheet in ThisWorkbook
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayAlerts = False
If .StatusBar = False Then appStatus = False Else appStatus = .StatusBar 'show currently processing file in status bar
End With
folder_path = "C:\Folder\SubFolder\" 'here are the files stored
file_name = Dir(folder_path & "*.csv") 'using dir to get file names
row_number = 3 'row number for pasting values
Set sht_csv = ThisWorkbook.Worksheets("2 CSV") 'target sheet for data aggregation
Do While file_name <> ""
Workbooks.Open (folder_path & file_name), UpdateLinks:=False, Local:=True 'open csv file
Set wb_src = Workbooks(file_name) 'assign opened csv file to variable
source_sheet_name = Left(file_name, InStr(file_name, ".") - 1) 'sheet name in csv is the same as the file name
Set sht_src = wb_src.Worksheets(source_sheet_name) 'assign source sheet to variable
If sht_src.Range("C1").Value2 = "OJ_POPIS" Then 'checks if the csv has the correct structure
sht_src.Range("A2:FZ2").Copy 'if so copies desired range
sht_csv.Range("B" & row_number).PasteSpecial 'and pastes it into target worksheet column B
End If
sht_csv.Range("A" & row_number).Value2 = file_name 'writes file name into column A
Application.CutCopyMode = False
wb_src.Close SaveChanges:=False
file_name = Dir() 'fetch next file name
row_number = row_number + 1
'the following lines is what I tried to fix the problem of random excel crashing
Set wb_src = Nothing
Set sht_src = Nothing
Application.StatusBar = "Processing file " & file_name
DoEvents
Application.Wait (Now + TimeValue("0:00:02"))
ThisWorkbook.Save 'save after every loaded file to see which files are causing the problem
Loop
MsgBox "Data from CSV files copied", vbOKOnly
Set sht_csv = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Source CSV files are encoded both in UTF-8 and ANSI (my ACP is ANSI, 1250) and ; delimited.
Group policy restricting macros doesn't apply to me. I can sign my own macros.
What I tried:
Lines of code at the end of the loop
Identifying and deleting files triggering the crash (they have nothing in common, seemingly random, by the time a remove half of them... what is the point)
Simplifying the macro
New workbook
Different machine
VPN On/Off
Thank you for your help!
First thing I'd try is include a proper error handler (not resume next), particularly with x64, and ensure 'Break on all unhandled errors' is selected in Tools / Options / General.
Second thing I'd try is avoid using the clipboard -
With sht_src.Range("A2:FZ2")
sht_cvs.Range("B" & row_number).Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
(no need then to clear CutCopyMode)
Third thing I'd try is don't filter with Dir but something like this -
sFilter = "*.cvs"
file_name = Dir$(, 15) ' without vbDirectory if not getting subfolders
Do While Len(file_name)
If file_name Like sFilter Then
' process file
End If
file_name = Dir$(, 15)
Loop
Fourth thing I'd try is a good cup of coffee!

Protecting Excel worksheets - Impossible?

I'm trying to share an Excel workbook, but with limited access to only a couple of visible sheets. This have proven to be much harder than first anticipated due to security loopholes with Excel and password protection of worksheets.
My problem arises due to some hidden sheets that needs to stay hidden and the contents inaccessible, but are required for calculations were the result is shown in the visible sheets.
So far I have tried to "super hide" the sheets in the VBA window and lock the VBA project. The idea is that the user then can't unhide the "super hidden" sheets without the VBA project password.
I have tried to add additional VBA code to counter certain "attacks", but I keep coming back to a known flaw that circumvents all my efforts:
Step 1:
Save or make sure that the Excel workbook is saved as .xlsx or .xlsm
Step 2:
Run the following code from a different workbook or your personal.xlsb that removes passwords from sheets and structure protection
(I would have linked to the post where I found the code, but I can't find it right now...).
Sub RemoveProtection()
Dim dialogBox As FileDialog
Dim sourceFullName As String
Dim sourceFilePath As String
Dim SourceFileName As String
Dim sourceFileType As String
Dim newFileName As Variant
Dim tempFileName As String
Dim zipFilePath As Variant
Dim oApp As Object
Dim FSO As Object
Dim xmlSheetFile As String
Dim xmlFile As Integer
Dim xmlFileContent As String
Dim xmlStartProtectionCode As Double
Dim xmlEndProtectionCode As Double
Dim xmlProtectionString As String
'Open dialog box to select a file
Set dialogBox = Application.FileDialog(msoFileDialogFilePicker)
dialogBox.AllowMultiSelect = False
dialogBox.Title = "Select file to remove protection from"
If dialogBox.show = -1 Then
sourceFullName = dialogBox.SelectedItems(1)
Else
Exit Sub
End If
'Get folder path, file type and file name from the sourceFullName
sourceFilePath = Left(sourceFullName, InStrRev(sourceFullName, "\"))
sourceFileType = Mid(sourceFullName, InStrRev(sourceFullName, ".") + 1)
SourceFileName = Mid(sourceFullName, Len(sourceFilePath) + 1)
SourceFileName = Left(SourceFileName, InStrRev(SourceFileName, ".") - 1)
'Use the date and time to create a unique file name
tempFileName = "Temp" & Format(Now, " dd-mmm-yy h-mm-ss")
'Copy and rename original file to a zip file with a unique name
newFileName = sourceFilePath & tempFileName & ".zip"
On Error Resume Next
FileCopy sourceFullName, newFileName
If Err.Number <> 0 Then
MsgBox "Unable to copy " & sourceFullName & vbNewLine _
& "Check the file is closed and try again"
Exit Sub
End If
On Error GoTo 0
'Create folder to unzip to
zipFilePath = sourceFilePath & tempFileName & "\"
MkDir zipFilePath
'Extract the files into the newly created folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(zipFilePath).CopyHere oApp.Namespace(newFileName).Items
'loop through each file in the \xl\worksheets folder of the unzipped file
xmlSheetFile = Dir(zipFilePath & "\xl\worksheets\*.xml*")
Do While xmlSheetFile <> ""
'Read text of the file to a variable
xmlFile = FreeFile
Open zipFilePath & "xl\worksheets\" & xmlSheetFile For Input As xmlFile
xmlFileContent = Input(LOF(xmlFile), xmlFile)
Close xmlFile
'Manipulate the text in the file
xmlStartProtectionCode = 0
xmlStartProtectionCode = InStr(1, xmlFileContent, "<sheetProtection")
If xmlStartProtectionCode > 0 Then
xmlEndProtectionCode = InStr(xmlStartProtectionCode, _
xmlFileContent, "/>") + 2 '"/>" is 2 characters long
xmlProtectionString = Mid(xmlFileContent, xmlStartProtectionCode, _
xmlEndProtectionCode - xmlStartProtectionCode)
xmlFileContent = Replace(xmlFileContent, xmlProtectionString, "")
End If
'Output the text of the variable to the file
xmlFile = FreeFile
Open zipFilePath & "xl\worksheets\" & xmlSheetFile For Output As xmlFile
Print #xmlFile, xmlFileContent
Close xmlFile
'Loop to next xmlFile in directory
xmlSheetFile = Dir
Loop
'Read text of the xl\workbook.xml file to a variable
xmlFile = FreeFile
Open zipFilePath & "xl\workbook.xml" For Input As xmlFile
xmlFileContent = Input(LOF(xmlFile), xmlFile)
Close xmlFile
'Manipulate the text in the file to remove the workbook protection
xmlStartProtectionCode = 0
xmlStartProtectionCode = InStr(1, xmlFileContent, "<workbookProtection")
If xmlStartProtectionCode > 0 Then
xmlEndProtectionCode = InStr(xmlStartProtectionCode, _
xmlFileContent, "/>") + 2 ''"/>" is 2 characters long
xmlProtectionString = Mid(xmlFileContent, xmlStartProtectionCode, _
xmlEndProtectionCode - xmlStartProtectionCode)
xmlFileContent = Replace(xmlFileContent, xmlProtectionString, "")
End If
'Manipulate the text in the file to remove the modify password
xmlStartProtectionCode = 0
xmlStartProtectionCode = InStr(1, xmlFileContent, "<fileSharing")
If xmlStartProtectionCode > 0 Then
xmlEndProtectionCode = InStr(xmlStartProtectionCode, xmlFileContent, _
"/>") + 2 ''"/>" is 2 characters long
xmlProtectionString = Mid(xmlFileContent, xmlStartProtectionCode, _
xmlEndProtectionCode - xmlStartProtectionCode)
xmlFileContent = Replace(xmlFileContent, xmlProtectionString, "")
End If
'Output the text of the variable to the file
xmlFile = FreeFile
Open zipFilePath & "xl\workbook.xml" & xmlSheetFile For Output As xmlFile
Print #xmlFile, xmlFileContent
Close xmlFile
'Create empty Zip File
Open sourceFilePath & tempFileName & ".zip" For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
'Move files into the zip file
oApp.Namespace(sourceFilePath & tempFileName & ".zip").CopyHere _
oApp.Namespace(zipFilePath).Items
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(sourceFilePath & tempFileName & ".zip").Items.count = _
oApp.Namespace(zipFilePath).Items.count
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
'Delete the files & folders created during the sub
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder sourceFilePath & tempFileName
'Rename the final file back to an xlsx file
Name sourceFilePath & tempFileName & ".zip" As sourceFilePath & SourceFileName _
& "_" & Format(Now, "dd-mmm-yy h-mm-ss") & "." & sourceFileType
'Show message box
MsgBox "The workbook and worksheet protection passwords have been removed.", _
vbInformation + vbOKOnly, Title:="Password protection"
End Sub
Step 3:
Run the following code to unhide all sheets
Sub UnhideAllSheets()
For Each Worksheet In ActiveWorkbook.Sheets
Worksheet.Visible = -1
Next Worksheet
End Sub
The workbook is now clean of passwords on sheets and structure protection, and any "counter" VBA code is gone by saving the workbook as a .xlsx file.
I have thought about adding a user-defined function that checks if the extension of the workbook file is ".xlsb". The function would return "1" if the extension is ".xlsb" and then multiplying it on something important. This would cause the calculations to fail if the workbook is saved as something else, or if the VBA project is entirely removed to saving as .xlsx.
However, I do not like this approach as I don't think it is a long-term solution...
My question is therefore:
Is there a way to securely share an Excel workbook with only access to a couple of sheets without risking the user can access hidden sheets and/or unwanted contents?
In the VBE you can change the Visible property of a specific sheet to xlSheetVeryHidden.
This will remove it from the front end completely.
You can then add a password to protect the VBA project in the VBE to prevent a user from changing that property (if they even know about it).
Additionally, you will still be able to access these sheets with your VBA code.
EDIT:
What I also add to the above is a password to the specific sheet, as normal. But also a custom UserForm the UserForm gets triggered on the Worksheet_Activate event if they had to unhide it. If they enter the incorrect password or close the UserForm the sheet gets hidden away again. You can add all sorts to this event handler such as reprotect the worksheet, reprotect the project, protect the workbook with an encrypted password and close the workbook as a "breach" in security.
The possibilities are endless. Not an exact prevention, but hopefully this helps.

Save new file with filename cell value

I am working on making a universal production time sheet(wbTime) for each dept that will work across all shifts and lines. I have where all the necessary information is required to be entered, all the data getting copied into a table in another workbook(wbLog) and saved to be able to do analysis on the production data.
However, when it gets to trying to save the actual time sheet in the proper folder according to shift and machine line I start running into problems. I have it pulling part of the path from certain cells and the filename form the date the enter. It is getting to the last line and throwing a run-time error 1004 "Method 'SaveAs' of object_Worbook'failed".
I have only been playing with vba for 2 months so it is probably something small that I just do not see...
Sub TransferData()
If ActiveSheet.Range("E2").Value = "" Then
MsgBox "Operator Name Required", vbInformation, "ALERT: Missing Information"
Cancel = True
Exit Sub
End If
If ActiveSheet.Range("H2").Value = "" Then
MsgBox "Date Required", vbInformation, "ALERT: Missing Information"
Cancel = True
Exit Sub
End If
If ActiveSheet.Range("K2").Value = "" Then
MsgBox "Shift Required", vbInformation, "ALERT: Missing Information"
Cancel = True
Exit Sub
End If
If ActiveSheet.Range("M2").Value = "" Then
MsgBox "Line Required", vbInformation, "ALERT: Missing Information"
Cancel = True
Exit Sub
End If
Dim wbTime As Workbook
Set wbTime = ThisWorkbook
Dim wbData As Workbook
Dim LastRow As Long
Set wbTime = ActiveWorkbook
With wbTime.Sheets("Production Time Sheet")
LastRow = .Range("E" & .Rows.Count).End(xlUp).Row
End With
wbTime.Sheets("Production Time Sheet").Range("A6:R" & LastRow).Copy
Set wbData = Workbooks.Open("S:\Lean Carrollton Initiative\Michael\Time Sheet Data LT Test.xlsm")
Set wbData = ActiveWorkbook
wbData.Worksheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
wbData.Close SaveChanges:=True
Dim Fname As String
Dim Path As String
Dim shft As String
Dim Line As String
Set wbTime = ActiveWorkbook
Fname = Sheets("Production Time Sheet").Range("I2").Text
shft = Sheets("Production Time Sheet").Range("Z9").Text
Line = Sheets("Production Time Sheet").Range("AC11").Text
Path = "K:\Groups\OFS Time Sheets\8hr Production Schedule\LT Jacketing\" & shft & Line & Fname & ".xlsx"
ActiveWorkbook.SaveAs filename:=Path, FileFormat:=xlNormal
End Sub
You are using as name of file the text 2/5/2019.xlsx. As far as I know, the simbol / cannot be used in Windows to name a file.
Try with a different name for file. Something like:
Fname = Replace(Sheets("Production Time Sheet").Range("I2").Text,"/","-")
a) Don't use Range.Text, use Range.Value2.
Text will give you exactly what is written in the cell, and if the cell diplays ###because your cell is to narrow to display a number, it will give you ###.
b) Put a statement Debug.print path before the SaveAs and check in the immediate window (Ctrl+G) if the path is exactly what you expect.
c) Be sure that when you issue the SaveAs-command, the same file is not already open in Excel - this happens often when you test your code repeatedly (it may still open from the last test). SaveAs saves a copy of the file and keeps it open!
d) Use FileFormat:=xlOpenXMLWorkbook when you name the file with extension xlsx. xlNormal will save the file with the old Excel file format and expects xls as extension.
e) Try to save the file with exactly the name from the Excel SaveAs dialog to see if the filename is okay and you have permission to save a file.

VBA code executes but only if I step thru it

I used some code from Close an opened PDF after opening it using FollowHyperlink to create the following code to open a pdf file and rename it. The code runs fine but only if I break execution at MsgBox "Break Here" and step into it with the F8 key. Any ideas on why it won't execute automatically?
Sub OpenPDF()
'Opens PDF Scaned file & saves it to another folder
'***ErrorHandler***
On Error Resume Next
'***Declare Objects****
Dim objectWMI As Object
Dim objectProcess As Object
Dim objectProcesses As Object
Dim Path As String
Dim MyDir As String
'***Opens a new workbook if there are no active workbooks***
'***There must be an active workbook for FollowHyperlink to function***
nowbs = Application.Workbooks.Count
If nowbs = 1 Then
Application.Workbooks.Add
Else
End If
'***Saves current Excel path
MyDir = CurDir
'***Sets path to Ricoh Scans
PDFDir = "S:\Ricoh Scans"
ChDir PDFDir
'***Gets filename for PDF scan
Path = Application.GetOpenFilename(filefilter:="PDF file (*.pdf), *.pdf")
'***Opens PDF file***
ActiveWorkbook.FollowHyperlink Path
'***Sets Excel as active application
AppActivate "Microsoft Excel"
'***Prompts for PO number****
MyPONum = InputBox("Enter PO Number", "PO Editor", "30500")
'***If user selects Cancel on inputbox then xl closes Acrobat and exits sub
If MyPONum = vbNullString Then
GoTo EndAll
Else
End If
'***Replaces scanned filename with inputbox filename
PathLen = Len(Path)
OldName = Mid(Path, 16, PathLen - 19)
NewName = "S:\Materials Management\Purchase Orders\PO " & MyPONum & ".pdf"
EndAll:
'***Set Objects***
Set objectWMI = GetObject("winmgmts://.")
Set objectProcesses = objectWMI.ExecQuery("SELECT * FROM Win32_Process WHERE Name = 'Acrobat.exe'") '< Change if you need be ** Was AcroRd32.exe**
'
'
'Code executes fine up to here but must Ctrl + Break at this line
'and F8 step thru balance of code or it will not work
'
'
MsgBox "Break Here"
'***Terminate all Open PDFs***
For Each objectProcess In objectProcesses
Call objectProcess.Terminate
Next
'***Clean Up***
Set objectProcesses = Nothing
Set objectWMI = Nothing
'***Renames scanned file and moves it to Materials Management folder***
Name Path As NewName
'***Resets current directory
ChDir MyDir
End Sub
Thanks to all for your input. I'm not a programmer and as I said I used code that had been posted elsewhere on this site. It was a timing issue and this edit works.
'***Terminate all Open PDFs***
For Each objectProcess In objectProcesses
objectProcess.Terminate
Next
'***Clean Up***
Set objectProcesses = Nothing
Set objectWMI = Nothing
'***************
Application.Wait (Now + TimeValue("00:00:02"))
'***Renames scanned file and moves it to Materials Management folder***
Name Path As NewName
'***Resets current directory
ChDir MyDir
End Sub

Auto copy-paste from Excel to Word works but no source formatting

I found a code on the Internet and I've adapted to my own use to automate copy-paste. Works great except that when I paste the Excel chart to my word report, the colors get changed to destination theme. I need to keep source formatting and as the report is final, I can't change the color scheme either.
For some reason Selection.PasteSpecial (wdChart) does not work, it's used as a simple paste. I've got hundreds of reports to paste two dozens of graphs to, please don't say I will have to do it manually! Help please!
'You must set a reference to Microsoft Word Object Library from Tools | References
Option Explicit
Sub ExportToWord()
Dim appWrd As Object
Dim objDoc As Object
Dim FilePath As String
Dim FileName As String
Dim x As Long
Dim LastRow As Long
Dim SheetChart As String
Dim SheetRange As String
Dim BookMarkChart As String
Dim BookMarkRange As String
Dim Prompt As String
Dim Title As String
'Turn some stuff off while the macro is running
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
'Assign the Word file path and name to variables
FilePath = ThisWorkbook.path
FileName = "Trust03.docx"
'Determine the last row of data for our loop
LastRow = Sheets("Summary").Range("A65536").End(xlUp).Row
'Create an instance of Word for us to use
Set appWrd = CreateObject("Word.Application")
'Open our specified Word file, On Error is used in case the file is not there
On Error Resume Next
Set objDoc = appWrd.Documents.Open(FilePath & "\" & FileName)
On Error GoTo 0
'If the file is not found, we need to end the sub and let the user know
If objDoc Is Nothing Then
MsgBox "Unable to find the Word file.", vbCritical, "File Not Found"
appWrd.Quit
Set appWrd = Nothing
Exit Sub
End If
'Copy/Paste Loop starts here
For x = 2 To LastRow
'Use the Status Bar to let the user know what the current progress is
Prompt = "Copying Data: " & x - 1 & " of " & LastRow - 1 & " (" & _
Format((x - 1) / (LastRow - 1), "Percent") & ")"
Application.StatusBar = Prompt
'Assign the worksheet names and bookmark names to a variable
'Use With to group these lines together
With ThisWorkbook.Sheets("Summary")
SheetChart = .Range("A" & x).Text
BookMarkChart = .Range("C" & x).Text
End With
'Tell Word to goto the bookmark assigned to the variable BookMarkChart
appWrd.Selection.Goto What:=wdGoToBookmark, Name:=BookMarkChart
'Copy the data from Thisworkbook
ThisWorkbook.Sheets(SheetChart).ChartObjects(1).Copy
'Paste into Word
appWrd.Selection.PasteSpecial (wdChart)
Next
'Turn everything back on
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.StatusBar = False
'Let the user know the procedure is now complete
Prompt = "The procedure is now completed." & vbCrLf & vbCrLf
Title = "Procedure Completion"
MsgBox Prompt, vbOKOnly + vbInformation, Title
'Make our Word session visible
appWrd.Visible = True
'Clean up
Set appWrd = Nothing
Set objDoc = Nothing
End Sub
Rather than using the Selection.PasteSpecial method I use Application.CommandBars.ExecuteMso ("PasteSourceFormatting")
Change your paste line from
appWrd.Selection.PasteSpecial (wdChart)
to
appWrd.CommandBars.ExecuteMso ("PasteSourceFormatting")
appWrd.CommandBars.ReleaseFocus
Unfortunately MSDN doesn't have much in the way of documentation on this.... Hope it works for you without much trouble
EDIT
After some digging I figured out the the idMso parameter for this method corresponds to the ribbon controls idMso. A complete list of these can be found for each office application by going to File -> Options -> Customize Ribbon and then for each command hover over it in the list and the ToolTip will have a Description followed by a term enclosed in parentheses. This term in the parentheses is the idMso string for that command.
2nd EDIT
So here is how I do it from Excel to PowerPoint:
'Copy the object
Wkst.ChartObjects("ChartName").Select
Wkst.ChartObjects("ChartName").Copy
'Select Slide
Set mySlide = myPresentation.Slides("SlideName")
mySlide.Select
'stall to make sure the slide is selected
For k = 1 To 1000
DoEvents
Next k
'paste on selected slide
PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
PPApp.CommandBars.ReleaseFocus
'sit and wait for changes to be made
For k = 1 To 5000
DoEvents
Next k
The wait loops with DoEvents (MSDN) are because this is within a loop pasting a dozen or so charts and then formatting them. I got errors in the next part of the loop (resizing the chart). But here I had to select the silde and wait for a moment before attempting the paste to make sure it was on the right slide. Without this it pasted on slide 1.
Nothing here sticks out to me as something you're ommitting but maybe it will help you see why it is not working.

Resources