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
Related
When I am trying to run the code below the following happens:
1) It opens a "Save PDF File As" Window
2) I have to manually type in the name
3) The code runs
I want to automate steps 1 and 2 so that the code runs without any manual inputs from me and saves it as whatever.pdf in whatever path.
I tried using ExportAsFixedFormat but the problem is that it is saving only the first page as pdf and the remaining 100+ records that are going through the mail merge are not being saved. On top of that, it still opens that Dialog Window from step 1.
ActiveDocument.ExportAsFixedFormat OutputFilename:=whatever.pdf, _
ExportFormat:=wdExportFormatPDF, etc.
The code:
Sub DoMailMerge()
Set myMerge = ActiveDocument.MailMerge
If myMerge.State = wdMainAndSourceAndHeader Or _
myMerge.State = wdMainAndDataSource Then
With myMerge.DataSource
.FirstRecord = 1
.LastRecord = 3
End With
End If
With myMerge
.Destination = wdSendToPrinter
.Execute
End With
End Sub
Any help on this would be greatly appreciated!
[Edit] Corrected object reference. Added SaveAs2
In the OP, an attempt is made to use a pseudo printer to save as a pdf. There are differences between the SaveAs pdf format and the variety of pdf pseudo printers. Is there a reason for printing to a PDF and saving that file, rather than doing a Save As and choosing the PDF format?
With myMerge
.Destination = wdSendToNewDocument
.Execute
End With
ActiveDocument.SaveAs2 "path & filename", wdFormatPDF
The following is sometimes needed to silence prompting with scripted saves. For the above tested method, there were no prompts, so it may not be needed.
Toggle off .DisplayAlerts before SaveAs
Application.DisplayAlerts = wdAlertsNone
ActiveDocument.SaveAs2 "path & filename", wdFormatPDF
Application.DisplayAlerts = wdAlertsAll
Or
Dim tempDisplayAlerts As Long
tempDisplayAlerts = Application.DisplayAlerts
Application.DisplayAlerts = wdAlertsNone
ActiveDocument.SaveAs2 "path & filename", wdFormatPDF
Application.DisplayAlerts = tempDisplayAlerts
I am trying to work on a paste and merge formatting macro in microsoft word. I am constantly copying from a website and then pasting from that website into Word. Unfortunately, the website format is always:
Text
Citation
I want the format to be:
"Text." Citation.
My code currently is
Sub Paste_Citation()
' Paste_Citation Macro
On Error Resume Next
Selection.PasteAndFormat (wdFormatSurroundingFormattingWithEmphasis)
Selection.TypeBackspace
Selection.TypeBackspace
Selection.TypeText Text:="."
End Sub
I cannot figure out how to a) to not have a paragraph space between the text and the citation, b)put parentheses around the text. If the text does not have a period at the end, then format like "blah blah". Otherwise, "blah blah." and c) not include the text if the text only includes spaces and a period. I know that I need to do an if statement for c, but I am not very familiar with VBA in Word. Could someone walk through the process with me?
Edit #1
x = Selection.PasteAndFormat(wdFormatSurroundingFormattingWithEmphasis)
'trying to set x equal to the pasted formatted value
Dim Txt As String
Dim Cit As String
Txt = Split(x, Chr(182))
'trying to split the text based on the paragraph symbol
'I am confused on what I need to do from there
Edit #2
I have been working on it longer, and I think that I am pretty close. I figured out how to paste the info and merge the formats, as well as how to delete the paragraph break. My issue now is that I cannot figure out how to have it put quotations around the first paragraph, bring the cursor to the end of the paste, and add a period at the end.
Sub PasteCitation()
'Modified code from http://www.vbaexpress.com/forum/archive/index.php/t-46321.html
Application.ScreenUpdating = False
Dim Txt As Range
Set Txt = Selection.Range
Txt.PasteAndFormat (wdFormatSurroundingFormattingWithEmphasis)
With Txt.Find
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
'Replace single paragraph breaks with a space
.Text = "([!^13])([^13])([!^13])"
.Replacement.Text = "\1 \3"
.Execute Replace:=wdReplaceAll
End With
Application.ScreenUpdating = True
End Sub
The red line of your programming should be to assign the downloaded 'Text' and 'Citation' to variables, say
Dim Txt As String
Dim Cit As String
Txt = "Whatever you scraped from tre website"
Cit = "Whatever else you scraped from the web"
With that accomplished you can start manipulating each of the strings and then place them in your document where you want, perhaps at the location of your current selection.
When you follow this method you may come to individual questions which can be answered quickly. Meanwhile, avoid the use of On Error Resume Next while you don't know what error might crop up and how you want to deal with it.
Here is the software/systems I am using:
Microsoft Office 2010;
Task Scheduler;
Windows Server 2008 R2 Standard
I am running some VBA code within an Excel file that does the following:
1. Retrieves Data from our Database via SQL/ODBC connections
2. Uploads data to a raw data table within the workbook and time stamps the workbook in a cell with the now function
3. Refreshes and formats each pivot table in the workbook
4. Exports and saves specified sheets as a PDF document and saves the document name with the time stamp from step 2
5. Saves the workbook
6. Emails that specific PDF document just created as an email attachment in Excel.
7. Closes the Excel Application
I run this whole series in a private sub called Workbook_Open which checks to see if current time matches the specified runtime. If it does, it runs steps 1-7, if it is an hour later, it closes the workbook (that way I can work on it other than that two hour window).
Here is the code being used:
*Note, this code below is run in the "ThisWorkbook" Excel Object.
'This Macro will use check to see if you opened the workbook at a certain time, if you did, then it will run the Report Automation Macros below.
Private Sub Workbook_Open()
HourRightNow = Hour(Now())
If HourRightNow = 13 Then
Call RefreshDataTables
Call RefreshPivotTables
Call SaveWorkbook
Call ExportToPDFFile
Call EmailPDFAsAttachment
Call CloseWorkbook
ElseIf HourRightNow = 14 Then
Call CloseWorkbook
End If
End Sub
Sub RefreshDataTables()
'
' RefreshDataTables Macro
' This Macro is used to refresh the data from the Dentrix Tables.
'
'This selects the table and refreshes it.
Sheets("raw").Select
Range("D4").Select
Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False
Worksheets("NomenclatureVBA").Range("A2").Formula = "=now()"
End Sub
Sub RefreshPivotTables()
'
' RefreshPivotTables Macro
' This Macro refreshes each Pivot Table in the document.
'
'This goes through each sheet and refreshes each pivot table.
Sheets("D0150 VS D0330 BY BIZLINE").PivotTables("D0150 vs D0330 by BIZLINE").PivotCache.Refresh
Columns("B:DD").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Sheets("D0150 VS D0330").PivotTables("D0150 COMP EXAM vs D0330 PANO").PivotCache.Refresh
Columns("B:DD").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Formnats to the specific date format below.
End Sub
'--------------------------------------------------------------------------------------------------------------
Sub SaveWorkbook()
' Saves Active (Open) Workbook
ActiveWorkbook.Save
End Sub
'**********************READY************************
'More simplified and tested version of the Export To PDF format
'Make sure to update the filePaths, worksheets,
Sub ExportToPDFFile()
Dim strFilename As String
'Considering Sheet1 to be where you need to pick file name
strFilename = Worksheets("NomenclatureVBA").Range("C2")
Sheets(Array("D0150 VS D0330", "D0150 VS D0330 BY BIZLINE")).Select
Sheets("D0150 VS D0330").Activate
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"\\****(ServerNameGoesHere)****\UserFolders\_Common\DentrixEntrpriseCustomReports\Public\Owner Reports\DataAnalystAutomatedReports\Reports\D0150 COMP EXAM vs D0330 PANO\" & strFilename & ".pdf" _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
Sheets("NomenclatureVBA").Select
'This is where the exporting ends, now we will proceed to email the file.
'-----------------------------------------------------------------------------
'The emailing begins here
'This says that if there is a file name stored in the strFileName variable, then....
End Sub
'This Macro Closes the workbook... Note that it closes the very specific workbook you choose.
Sub CloseWorkbook()
'Workbooks("Automated D0150 COMP EXAM vs D0330 PANO.xlsm").Close SaveChanges:=False
Application.DisplayAlerts = False
Application.Quit
End Sub
Then I also have the macro that emails the PDF file in the Modules section of VBA. It looks like this:
Sub EmailPDFAsAttachment()
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010.
' This example sends the last saved version of the Activeworkbook object .
Dim OutApp As Object
Dim OutMail As Object
Dim FilePath As String
'This part is setting the strings and objects to be things. (e.g. FilePath is setting itself equal to the text where we plan to set up each report)
FilePath = "\\***(ServerGoesHere)***\UserFolders\_Common\DentrixEntrpriseCustomReports\Public\Owner Reports\DataAnalystAutomatedReports\Reports\D0150 COMP EXAM vs D0330 PANO\" _
& Worksheets("NomenclatureVBA").Range("C2") & ".pdf"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
' Change the mail address and subject in the macro before you run it.
'
With OutMail
.To = "email#example.com"
.CC = ""
.BCC = ""
.Subject = Worksheets("NomenclatureVBA").Range("C2")
.HTMLBody = "Hello all!" & "<br>" & _
"Here is this week's report for the Comp Exam vs. Pano." & "<br>" & _
"Let me know what you think or any comments or questions you have!" & "<br>" & _
vbNewLine & Signature & .HTMLBody
.Attachments.Add FilePath
' In place of the following statement, you can use ".Display" to
' display the mail.
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
So this all runs fine when I open up the workbook at the 13th hour (1pm), however, when I try to run this in Task Scheduler during the 13th hour, it runs everything up until the EmailPDFAsAttachment macro/sub and it gets hung up somewhere in the macro and stops running.
I should also state that I have the Trust Center Settings to the following in both Outlook and Excel:
TrustCenterSettings
Anyone know whats causing the macro to run perfectly when I personally open the file and then when I try and open the file via Task Scheduler it stalls in the same spot?
And anyone know how to make it run correctly via Task Scheduler?
Thanks!
We realized that the server limited my permissions in the task scheduler. When I went my IT Director switched my permissions to Admin, it ran the task scheduler perfectly!
Sorry for the false alarm... I wouldn't have posted the question originally, but I spent all last week working on it. Thanks everybody for looking!
That was my guess. You have to mkae sure your password is entered correctly. If you fat-finger a key and enter your password incorrectly, the Task Scheduler will accept it even though it shouldn't. In my opionion, it should prompt the user and notify him/her of the error. Maybe Microsoft will change this sometime in the near future.
I have a VBA subroutine which performs miscellaneous formatting to Word documents. It relies on the Selection object (Selection.WholeStory) to apply the formatting.
This subroutine is called from VBA Outlook with a Word.Application object.
The problem that arises is: when another instance of Word is open when the macro is called, the Selection Object refers to the Word document already open, not the handler created in my macro.
VBA does not seem to qualify the selection objct, so when you write Selection.PageSetup (ie) and start applying changes, it is applied to the Document already open in Word, not the document you are handling from VBA.
I've looked around for the answer on MSDN and here, but to no luck. If anyone knows how to qualify this object, let me know. Thanks.
Basically,
create word handler
open attachment in word
Selection.WholeStory
With Selection.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
/* etc */
End with
Since "Selection" cannot be qualified, all these changes get made to whatever is already open.
if numTextFiles >= 1 then
for each textFile in textFileNames
'Open text file in word
Set doc = WordApp.Documents.Open(outReportFullDir & "\" & textFile)
'Set the output name of word doc (change .txt to .docx)
reportWordName = left(textFile, len(textFile) - 4)
reportWordName = reportWordName & ".docx"
'Check if out word document already exists
preventOverwrite(outReportFullDir & "\" & reportWordName)
'Format Reports
formatReport()
'etc
_
Private Sub formatReport()
documents(docToFormat).select
Selection.WholeStory
'Added by Ryan to make single-spaced
WordBasic.OpenOrCloseParaBelow
WordBasic.OpenOrCloseParaBelow
Selection.Font.Name = "Courier New"
Selection.Font.Size = 8
With Selection.PageSetup
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With
End Sub
There is probably confusion between Word's selection object and Outlook's selection object.
Use
WordApp.Selection
i.e.
WordApp.Selection.WholeStory
WordApp.Selection.Font.Name = "Courier New"
etc.
(or e.g.
Dim sel as Word.Selection
Set sel = WordApp.Selection
sel.WholeStory
sel.Font.Name = "Courier New"
Set sel = Nothing
So that if WordApp is not in scope, you should be able to use something like
Set sel = doc.Application.Selection
)
Finally, if you can get away with using Word Range instead, I would do so (e.g. doc.Range or Doc.Content) and avoid the whole Selection thing.
Have you tried something like this? It looks like you're getting a proper reference to the correct document at one stage in the game.
if numTextFiles >= 1 then
for each textFile in textFileNames
'Open text file in word
Set doc = WordApp.Documents.Open(outReportFullDir & "\" & textFile)
'Set the output name of word doc (change .txt to .docx)
reportWordName = left(textFile, len(textFile) - 4)
reportWordName = reportWordName & ".docx"
'Check if out word document already exists
preventOverwrite(outReportFullDir & "\" & reportWordName)
'Format Reports
Call formatReport(doc)
'etc
Private Sub formatReport(ByRef doc)
documents(doc).select
Selection.WholeStory
'Added by Ryan to make single-spaced
WordBasic.OpenOrCloseParaBelow
WordBasic.OpenOrCloseParaBelow
Selection.Font.Name = "Courier New"
Selection.Font.Size = 8
With Selection.PageSetup
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With
End Sub
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.