Excel2010: PasteSpecial failing when copying from IE - vba

I'm building a model that attempts to pull data from the web across different websites using Select All > Copy. Below is the code that I have, and it seems to work in break mode in certain areas, and in other areas it only works when I run the macro.
The portion that is puzzling me at the time is when it hits: "ActiveSheet.PasteSpecial Format:="Text", link:=False, DisplayAsIcon:=False" , it fails and gives me Error 1004 "PasteSpecial method of Worksheet class failed."
On hitting F8 after debugging, the code continues just fine (albeit after showing me "Can't Execute code in break mode 3 times). I've tried altering the code to show "Worksheets("GOOGLE")" and other methods of defining the worksheet directly. My hunch is that may not be the issue. If that's the case, I have no idea what's going on here! Can someone test this out?
FYI I also use a Userform (modeless) on top of this code as a "Waiting" message as it can be quite long to run. Not sure if this is interfering with the paste.
Dim IE As Object
Dim PauseTime, Start
PauseTime = 22 ' Set duration in seconds
Start = Timer ' Set start time.
Application.ScreenUpdating = False
Worksheets("GOOGLE").Activate
Worksheets("GOOGLE").Cells.Clear
Worksheets("GOOGLE").Range("A1").Copy
Application.CutCopyMode = False
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate Range("GOOGLEURL").Value
Do Until .ReadyState = 4: DoEvents: Loop
End With
Do While Timer < Start + PauseTime
DoEvents
Loop
IE.ExecWB 17, 0 '// SelectAll
IE.ExecWB 12, 2 '// Copy selection
ActiveSheet.Range("A1").Select
ActiveSheet.PasteSpecial Format:="Text", link:=False, DisplayAsIcon:=False
IE.Quit
On Error GoTo Ending
IE.Quit
Application.CutCopyMode = False
Ending:
Application.CutCopyMode = False
Exit Sub

Try this method instead of copy/paste between applications. Like you, I tried that and found it unreliable and often didn't work.
You can grab the page's innerText in a string and just use that, or, you could split the innerText in to an array and put that on the sheet, as I do in my example. This preserves the line breaks and makes it a bit more readable than putting all the text in a single cell
I verify this on a simple example (http://google.com) that both methods return the exact same layout of cells in the worksheet.
NOTE: This method may not work when you have the ChromeFrameBHO Add-In installed in IE (see here).
Sub Test()
Dim IE As Object
Dim pageText As String
Dim page As Variant
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate "http://google.com"
Do Until .ReadyState = 4: DoEvents: Loop
End With
pageText = IE.Document.body.innertext
page = Split(pageText, vbCr)
Range("A1").Resize(UBound(page)).Value = Application.Transpose(page)
IE.Quit
Set IE = Nothing
End Sub
Another method which doesn't rely on Internet Explorer is the QueryTables method. It may or may not be appropriate for your needs, but try something like this.
NOTE: This method appears to work (for me) whether the ChromeFrameBHO plugin is installed.
Sub TestQueryTables()
Dim googleURL as String
googleURL = Range("GOOGLEURL")
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & googleURL _
, Destination:=Range("A1"))
.Name = googleURL
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone 'or use xlWebFormattingAll to preserve formats
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End Sub

I actually have been struggling with this exact same issue from copy and pasting a bunch of images. Excel 2010 apparently has issues with trying to paste before the copy command is complete. What you can do is a combination of the sleep event and error handling the specific 1004 error. Set up the error handler to catch the 1004 error, and just have it resume. What I did was set up a counter like this:
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
On Error GoTo ErrorHandler:
Dim err_counter As Integer
ErrorHandler:
If Err.Number = 1004 Then
err_counter = err_counter + 1
If err_counter > 10 Then
MsgBox ("The copy function is taking too long. Consider using smaller images.")
Exit Sub
End If
DoEvents
Sleep 500
DoEvents
ElseIf Err.Number <> 0 Then
MsgBox ("Unknown error.")
On Error GoTo 0
Resume
End If
You don't need to use an error counter, but I thoguht it would be a good idea to keep future users of my spreadsheet from somehow creating an infinite loop. I also would clear the clipboard after each image paste, and if you use an error counter, reset it to 0 after a paste is successful.

It looks like you're copying but you're clearing the clipboard before you paste so there's nothing for the code to paste.
Worksheets("GOOGLE").Range("A1").Copy
Application.CutCopyMode = False
Also, are you copying from Sheets("Google").Range("A1") to Sheets("Google").Range("A1")? I don't understand that

I am not in a position to verify my response but I had a similar issue about a year ago. The webpage in question had to use a copy/paste rather than using innertext. It seems you have done most of what I did including pausing waiting or the copy to complete. (Readystate was unhelpful for me.)
The last thing I remember doing, which allowed the code to work, was to place the paste in a finite loop. The paste was typically successful between the third and eighth attempt.
I'm sure there is a better way but was unable to find it. Since my application was for my own use the code was acceptable. As the webpage would change every few months, the code was abandoned.

Related

Auto answer message box

I am writing a short script compiling other macros.
It allows me to run three macros at once if I want to, rather than each one one by one.
I don't want to have the reply to the message boxes in the other 3 macros. The default answer is fine.
I am using the Application.DisplayAlerts = False method. Here:
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Run "Mod_Patients.MettreDatesAJourPatients"
Application.Run "Mod_Prescripteurs.MettreDatesAJourPrescripteurs"
Application.Run "Mod_Services.MettreDatesAJourServices"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Data has been updated"
Only that the Application.DisplayAlerts false/true does not work.
The subsequent message boxes appear.
I can't find a workaround.
Here's what Scott is suggesting:
Sub MettreDatesAJourPatients(Optional WarnUser as Boolean = True)
'....
'....
If WarnUser Then Msgbox "Something something..."
'....
End Sub
When called with no arguments WarnUser will be True: if you want to suppress any messages then call with:
MettreDatesAJourPatients False

How to shorten this VBA Code (preferably with loop)?

How can I shorten this sample code (preferably with a loop)?
NPCodes_Doc1.Close False
NPCodes_Doc2.Close False
NPCodes_Doc3.Close False
NPCodes_Doc4.Close False
NPCodes_Doc5.Close False
The VBA for MS Word that I created is getting the "Procedure too large" error and hence, I want to shorten my code.
The NPCodes_Doc variables are .docx files that are being opened and contents pasted into the main doc.
There are 118 .docx files related to this... Here's one of the 118 blocks of If statements to give you the idea:
If NPCodes Like "*Document1*" Then
Set NPCodes_Doc117 = Documents.Open(NPCodes_Path & "\" & "Document1.docx")
Selection.WholeStory
Selection.Font.Name = "Arial"
Selection.ParagraphFormat.SpaceAfter = 0
Selection.ParagraphFormat.SpaceBefore = 0
Selection.ParagraphFormat.LineSpacing = 12
Selection.Copy
Documents("Code Template.docm").Activate
Selection.EndKey Unit:=wdLine
Selection.Collapse Direction:=wdCollapseEnd
Selection.Paste
End If
So there are 118 documents for the code to choose from and with every match, that doc is opened and copied into the main one. After all of the 118 docs have been searched, the matched (opened and copied) docs are then closed with:
On Error Resume Next
NPCodes_Doc1.Close False
NPCodes_Doc2.Close False
NPCodes_Doc3.Close False
NPCodes_Doc4.Close False
NPCodes_Doc5.Close False
.... _Doc118.Close False
On Error GoTo 0
Taken on its own, this code
NPCodes_Doc1.Close False
NPCodes_Doc2.Close False
NPCodes_Doc3.Close False
NPCodes_Doc4.Close False
NPCodes_Doc5.Close False
cannot be shortened. NPCodes_Doc1, NPCodes_Doc2 etc. are completely separate variables, and there's no way to refer to them collectively.
Is there any reason you would want to open all of your 118 document at once? I'm guessing not. You should probably restructure your code to open only one document at a time, copy-paste from it, then close it, and move on to the next document. Repeat. <-- That's a loop right there.
I can't see your specifics, so I can't write working code for you, but it would look something like this:
Dim doc As Document
For i = 1 To 118
Set doc = Documents.Open(NPCodes_Path & "\" & "Document" & i & ".docx")
'
' put code to copy and paste here
'
doc.Close False
Next i

Issue with Excel VBA crashing constantly

I'm building a sheet that will change depending on some selections. I have ranges defined that will be used to copy and paste the different data depending on what kind of sheet should get displayed to the user.
Since I built the copy and pasting mechanism, the sheet has been crashing a lot when I run the code to swap the sheet to look differently.
I get "Method 'PasteSpecial' of object 'Range' failed" on my error check and then "Run-time error "-2147417848 (80010108)': Automation error The object invoked has disconnected from its clients." that randomly will occur, sometimes the sheet runs fantastic with no errors and othertimes it is swamped with errors. Usually after this error comes up, I will hit end, and then I'll get a "Microsoft Excel has stopped working" error "windows can try to restart the program". It sometimes recovers but normally not.
I have attempted to copy the cells and paste them without any macros or code and excel has been crashing. I am copy and pasting a bunch of formatted borders and background colours as well as some text that are in the boxes as well.
Public Sub SetupSheetForEquipmentType(equipment As EquipType)
Dim ws As Worksheet
Set ws = Sheets("Input")
Dim info As Worksheet
Set info = Sheets("Info")
Call Unprotect(ws)
ws.Range("selectedEquipType") = equipment
'Normarc Style
'show all rows first
On Error Resume Next
If ws.Rows(14).EntireRow.Hidden = True Then
ws.Rows(14).EntireRow.Hidden = False
ws.Rows(16).EntireRow.Hidden = False
ws.Columns(2).EntireColumn.Hidden = False
End If
On Error GoTo errSec
'setup the sheet
'Application.DisplayAlerts = False
'Application.ScreenUpdating = False
Select Case equipment
Case Is = 2
ws.Range("title") = "ILS PHL7801 MONITOR READINGS"
Case Is = 3
ws.Range("title") = "ILS NORMARC 'A' MONITOR READINGS"
Case Is = 4
ws.Range("title") = "ILS NORMARC 'B' MONITOR READINGS"
End Select
If Not equipment = PHL7801 Then
ws.Rows(24).RowHeight = 15
ws.Rows(25).RowHeight = 15
ws.Columns(3).ColumnWidth = 6
'make the sheet input look appropriate
info.Range("NMSheet").Copy
DoEvents
DoEvents
DoEvents
ws.Range("SheetGuts").PasteSpecial xlPasteAll '************crashes here*********** but works with xlPasteValues
'put the comment box in
info.Range("NMComment").Copy
ws.Range("NMCommentRef").PasteSpecial
ThisWorkbook.Names("comment").Delete
ws.Range("I35").Name = "comment"
End If
Select Case equipment
Case Is = NMA
info.Range("NMACL").Copy
DoEvents
DoEvents
DoEvents
DoEvents
ws.Range("NMCPNames").PasteSpecial xlPasteAllExceptBorders, xlPasteSpecialOperationNone
info.Range("NMADS").Copy
DoEvents
DoEvents
DoEvents
DoEvents
ws.Range("NMDSNames").PasteSpecial xlPasteAllExceptBorders, xlPasteSpecialOperationNone
info.Range("NMARef").Copy
DoEvents
DoEvents
DoEvents
DoEvents
ws.Range("NMRefNames").PasteSpecial xlPasteAllExceptBorders, xlPasteSpecialOperationNone
Case Is = NMB
info.Range("NMBCL").Copy
DoEvents
DoEvents
DoEvents
DoEvents
ws.Range("NMCPNames").PasteSpecial xlPasteAllExceptBorders, xlPasteSpecialOperationNone
info.Range("NMBDS").Copy
DoEvents
DoEvents
DoEvents
DoEvents
ws.Range("NMDSNames").PasteSpecial xlPasteAllExceptBorders, xlPasteSpecialOperationNone
info.Range("NMBRef").Copy
DoEvents
DoEvents
DoEvents
DoEvents
ws.Range("NMRefNames").PasteSpecial xlPasteAllExceptBorders, xlPasteSpecialOperationNone
Case Is = PHL7801
'make the sheet input look appropriate
info.Range("PHLSheet").Copy
DoEvents
DoEvents
DoEvents
ws.Range("SheetGuts").PasteSpecial
'hide the rows that aren't applicable and size them appropriately
ws.Columns(2).Hidden = True
ws.Rows(14).Hidden = True
ws.Rows(16).Hidden = True
ws.Rows(24).RowHeight = 30
ws.Rows(25).RowHeight = 30
ws.Columns(3).ColumnWidth = 10
info.Range("PHLCL").Copy
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
ws.Range("NMCPNames").PasteSpecial xlPasteAllExceptBorders, xlPasteSpecialOperationNone
info.Range("PHLDS").Copy
DoEvents
DoEvents
DoEvents
DoEvents
ws.Range("NMDSNames").PasteSpecial xlPasteAllExceptBorders, xlPasteSpecialOperationNone
info.Range("PHLRef").Copy
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
ws.Range("NMRefNames").PasteSpecial xlPasteAllExceptBorders, xlPasteSpecialOperationNone
'put the comment box in
info.Range("PHLComment").Copy
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
ws.Range("NMCommentRef").PasteSpecial xlPasteAll, xlPasteSpecialOperationNone
ThisWorkbook.Names("comment").Delete
ws.Range("D35").Name = "comment"
End Select
errSec:
If Err.Number <> 0 Then
MsgBox "Error: " & Err.Description
Err.Clear
End If
Call Protect(ws)
'Application.ScreenUpdating = True
'Application.DisplayAlerts = True
End Sub
Edit:
I also have been reading and determined that dumping the temporary files is supposed to help, located here: C:\Users\username\AppData\Local\Temp. Between that and Charles's answer, it seems to be working okay, except I'm getting an error on my catch saying: "To do this, all the merged cells need to be the same size". I am wondering if there is an issue with all the merged cells I have?
Edit Again: I spoke too soon. I noticed that the copy and paste was not working correctly by using the xlpastevalues, so I changed it to xlPasteAll and its now crashing again.
It looks like your missing the paste values
ws.Range("SheetGuts").PasteSpecial xPasteValues
Instead of .Copy and then .PasteSpecial xlPasteAll (and also avoiding the repetitive DoEvents, can you see if this works:
ws.Range("NMRefNames").Unmerge
info.Range("NMSheet").Copy Destination:=ws.Range("NMRefNames")
You may also need to do similar on the next block:
info.Range("NMComment").Copy
ws.Range("NMCommentRef").PasteSpecial
If there are or may be merged cells:
info.Range("NMComment").Copy Destination:=ws.Range("NMCommentRef")
ws.Range("NMCommentRef").Value = ws.Range("NMCommentRef").Value 'Gets rid of formula/etc
Also, for your PasteAllExceptBorders blocks, try doing this on all of them:
info.Range("NMBDS").Copy Destination:=ws.Range("NMDSNames")
ws.Range("NMDSNames").Borders.LineStyle = xlNone

Why is this "Delete Method of Range class failed" error popping up?

I am trying to figure out why this "Delete Method of Range Class" error is popping up. It does not always occur when this macro runs, which makes it all the more perplexing.
Can anybody explain this?
Sub ResetSheet()
If WindowsOS Then
'*******************************************************************************************************'
'Resets the Data sheet. Called by the resetSheetButton procedure (located in module: m7_Macros1_5). '
'Also called by the OkCommandButton_Click procedure in the OnOpenUserForm form. '
'*******************************************************************************************************'
Application.EnableEvents = False
Sheet4.Visible = True
Sheet4.Activate
Sheet4.Select
Sheet4.Rows("2:101").Select
Selection.Copy
'TC Edit
Sheet1.Activate
Sheet1.Range("A2").PasteSpecial (xlPasteAll)
'Sheet1.Paste
Sheets("Data").Select
Sheet1.Rows("102:10000").EntireRow.Delete
Sheet4.Visible = False
'TC Edit 2.0 - Adding code to reset the exception checkboxes
If WindowsOS Then
Call resetCheckBoxes
End If
Application.EnableEvents = True
This is the macro code that causes the error (sometimes)
This is the error pop-up
try with below simplified code
Sub ResetSheet()
'If WindowsOS Then
Application.EnableEvents = False
With Worksheets("Sheet4")
.Visible = True
.Rows("2:101").Copy Worksheets("Sheet1").Range("A2")
End With
With Worksheets("Sheet1")
.Rows("102:101").EntireRow.Delete
End With
Worksheets("Sheet4").Visible = False
If windowsOS Then
Call resetCheckBoxes
End If
Application.EnableEvents = True
End Sub

VBA to Enter Data Online and Submit Form

I'm trying to use VBA to submit data from Excel to a webform online. The issue happens within the * area where I'm trying to select and update the form. I've tried a variety of options (getelement by ID, name, etc.) without any success. I believe the issue has to do with identifying the appropriate element. I've seen advice about using the Locals feature in VBA, but I'm not sure how to use that for this purpose. I have a feeling someone with some experience could figure this out very quickly by looking at the source code on the webiste, using Locals in VBA, or some other technique.
The form is set up so all fields are text and I can enter/submit data online with no problem.
Thanks in advance for any help/suggestions.
Dim IE As Object
Sub submitFeedback3()
Application.ScreenUpdating = False
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
IE.Navigate "http://spreadsheetbootcamp.com/excel-efficiency-trainer-feedback/"
Application.StatusBar = "Submitting"
' Wait while IE loading...
While IE.Busy
DoEvents
Wend
**********************************************************************
IE.Document.getElementById("Form_Attempts-1372643500")(0).Value = "1"
IE.Document.getElementById("submit-1-1372643500")(0).Click
**********************************************************************
Application.StatusBar = "Form Submitted"
IE.Quit
Set IE = Nothing
Application.ScreenUpdating = True
End Sub
Try below code
Dim IE As Object
Sub submitFeedback3()
Application.ScreenUpdating = False
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
IE.Navigate "http://spreadsheetbootcamp.com/excel-efficiency-trainer-feedback/"
Application.StatusBar = "Submitting"
' Wait while IE loading...
While IE.Busy
DoEvents
Wend
' **********************************************************************
delay 5
IE.Document.getElementById("experience-1372700847").Value = "ddddd1"
delay 5
IE.Document.getElementById("Form_Time_Best-1372700847").Value = "ddddddddddd2"
delay 5
IE.Document.getElementById("submit-1-1372700847").Click
'**********************************************************************
Application.StatusBar = "Form Submitted"
IE.Quit
Set IE = Nothing
Application.ScreenUpdating = True
End Sub
Private Sub delay(seconds As Long)
Dim endTime As Date
endTime = DateAdd("s", seconds, Now())
Do While Now() < endTime
DoEvents
Loop
End Sub