After reading many sources and copying-pasting a lot I have come up with a macro for MS Word 2010 to calculate my work done at the end of the day.
What it does:
Opens each DOCX file in a specified directory.
Copies text from the right part of a two-column table that I use for translations.
Opens the statistics file and pastes clipboard at the top of the file.
When no more files are left to process, the macro prints statistics at the top of the statistics file.
It works all right. However, I'd love to make it work faster. If I use the macro to process like 50-100 files, it may slow down after 10-15 to 1 file per second perhaps. I am at a loss. I guess I didn't choose the right tool for the job. Can I make this code run faster?
I've tried to experiment with:
1.Passing arguments to open file command (AddToRecentFiles:=False which added a negligible improvement if at all).
2.Setting Window.Visible = False to subroutines but then the macro does not copy any text.
I am not even sure what oDoc does in:
Set oDoc = Documents.Open(FileName:=vDirectory & vFile, AddToRecentFiles:=False)
Lots of Googling, copy-pasting with only basic knowledge. Sorry about that. But I am willing to learn.
'Create variables to use later
Dim vDirectory As String
Dim vFileTarget As String
Dim vStat1 As Variant
Dim vStat2 As Variant
'Variables to clear clipboard in case of errors
Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function EmptyClipboard Lib "user32" () As Long
Public Declare Function CloseClipboard Lib "user32" () As Long
Sub GoodStats()
vDirectory = "C:\Users\Job\Calculate\" 'Files to process
vFile = Dir(vDirectory & "*.docx*") 'Extension of the files to process
vFileTarget = "C:\Users\Job\stats.docx" 'File for the final count
Application.ScreenUpdating = False
DeleteOld 'Prepare final count file for new calculation
Do While vFile <> "" 'Get this show on the road
Set oDoc = Documents.Open(FileName:=vDirectory & vFile, AddToRecentFiles:=False)
TextCopy
TextMove
vFile = Dir
Loop
'Proceed to next function because there are no files left to process
FinalRun
Application.ScreenUpdating = True
End Sub
Function DeleteOld()
'Previous statistics is deleted from final count file
Documents.Open FileName:=vFileTarget
Selection.WholeStory
Selection.Delete Unit:=wdCharacter, Count:=1
ActiveDocument.Save
End Function
'Primary cycle of document open, copy, paste begins
Function TextCopy() 'Copy text from right part of the table
On Error GoTo ErrorHandler 'Goes to error handler if there is no text on the right side
Selection.MoveRight Unit:=wdCell
Selection.Copy
ActiveWindow.Close
Exit Function
ErrorHandler: 'If there is no text, close document, proceed to next function
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
ActiveWindow.Close
Exit Function
End Function
Function TextMove() 'Move copied text to final count file
On Error GoTo ErrorHandler
Documents.Open FileName:=vFileTarget
Selection.PasteAndFormat (wdFormatOriginalFormatting)
Selection.HomeKey Unit:=wdStory
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Font.Bold = wdToggle
Selection.HomeKey Unit:=wdLine
Selection.TypeParagraph
Selection.TypeParagraph
Selection.TypeParagraph
Selection.HomeKey Unit:=wdStory
ActiveDocument.Save
ActiveWindow.Close
ErrorHandler: 'If error, close document and move on
Exit Function
End Function
Function FinalRun()
'Open the final count file to calculate statistics
Documents.Open FileName:=vFileTarget
Selection.HomeKey Unit:=wdStory
'Calculate number of symbols and spaces
vStat1 = ActiveDocument.ComputeStatistics(Statistic:=wdStatisticCharactersWithSpaces)
'Translation pages = symbols + spaces divide by 1860
vStat2 = Round((ActiveDocument.ComputeStatistics(Statistic:=wdStatisticCharactersWithSpaces) / 1860), 2)
Selection.TypeText Text:=vStat1 & " symbols with spaces" 'First statistics line
Selection.TypeParagraph
Selection.TypeText Text:=vStat2 & " translated pages"
'Money = pages multiplied by 10000
Selection.TypeParagraph
Selection.TypeText Text:=vStat2 * 10000 & " rubles for all the translations"
ActiveDocument.Save
End Function
UPDATE
Thanks to KazJaw I now have the macro I want. Thanks a lot for directing me to the Range feature. The new macro does not copy files but calculates statistics from selections in each file one by one, adds all the numbers and displays the results in a message box. And it definitely feels faster.
UPDATE 2
I've added
Application.Visible = False
and the macro works like that. I've also added a timer to calculate the execution time and the macro now loops through 173 files in about 10 seconds :)
Sub GoodStats()
'Create variables to use later
Dim vDirectory As String
Dim charCount As Single
Dim tcharCount As Single
Dim pageCount As Single
Dim moneyCount As Single
Dim myRange As Range
Dim startTime As Double
'Clear basic statistics number if you run macro multiple times
tcharCount = 0
startTime = Timer
'Folder to process
vDirectory = "C:\Users\Job\Calculate\"
'Extension of the files to process
vFile = Dir(vDirectory & "*.docx*")
'Don't want all those files popping up
Application.ScreenUpdating = False
Application.Visible = False
'Get this show on the road
Do While vFile <> ""
Set oDoc = Documents.Open(FileName:=vDirectory & vFile, AddToRecentFiles:=False)
'Switch to the right column
Selection.MoveRight unit:=wdCell
Set myRange = ActiveDocument.Range(Selection.Start, Selection.End)
'Get the initial number
charCount = myRange.ComputeStatistics(Statistic:=wdStatisticCharactersWithSpaces)
'Add the current document stats to overall stats
tcharCount = tcharCount + charCount
ActiveWindow.Close
vFile = Dir
Loop
'Translation pages = symbols + spaces divide by 1860
pageCount = Round((tcharCount / 1860), 2)
moneyCount = pageCount * 10000
Application.ScreenUpdating = True
Application.Visible = True
Done = Timer - startTime
'Show the results in a message box with multiple lines
MsgBox tcharCount & " total characters" & vbCrLf & _
pageCount & " total pages" & vbCrLf & _
moneyCount & " total money" & vbCrLf & _
"Done in " & Done & " seconds"
End Sub
First of all- opening and closing documents is time consuming!
Second, selecting is usually inefficient way of working with Word documents, Excel ranges, Office shapes, etc.
Instead of that you could try to set reference to Object Variable and operate with your text by working with your variable. However, it requires some changes in your code and different approach.
Below you will find a part of your code (Function TextMove()) which I transformed from Selection approach to Object Variable approach. I kept your code (in comments) that you could compare what is instead of which part of the code. This code do the same but it should run much faster.
Function TextMove() 'Move copied text to final count file
On Error GoTo ErrorHandler
Documents.Open FileName:=vFileTarget
Selection.PasteAndFormat (wdFormatOriginalFormatting)
'CHANGES AS OF THIS SECTION
Dim myRange As Range
Selection.HomeKey unit:=wdStory
'Selection.EndKey unit:=wdLine, Extend:=wdExtend
Set myRange = ActiveDocument.Range(0, Selection.EndKey(wdLine, wdExtend))
'Selection.Font.Bold = wdToggle
myRange.Font.Bold = wdToggle
'Selection.HomeKey unit:=wdLine
'Selection.TypeParagraph
'Selection.TypeParagraph
'Selection.TypeParagraph
myRange.InsertBefore Chr(13) & Chr(13) & Chr(13)
'Selection.HomeKey unit:=wdStory
myRange.MoveStart wdStory '<< but you rather don't need it
'END OF CHANGES
ActiveDocument.Save
ActiveWindow.Close
ErrorHandler: 'If error, close document and move on
Exit Function
End Function
Related
I have a word file with some spaces, for example:
Word File XXXXX
Title: XXXXX
etc
And I have another word file which have that data that is missing:
Word File 20248
Title: Example of word file
etc
My question is, how can I use vba to recognize the data from the first file to be copied into the second file in the spaces I want. Furthermore I'd prefer that you can select the word file you want with a dialog box rather than putting in the code where the file is located as I have different files that can have the location changed.
Thank you so much for your answers. I'm pretty new in vba and I have never used it on word.
By now I have this code to choose the word file from which I want to copy the data:
Sub CopyData()
Dim DC As Document
Dim wD As Document, strD As String, wDNumb As Variant
Dim I As Long
Set wD = ActiveDocument
DSelection:
For I = 1 To Documents.Count
strD = strD & Documents(I).Name & " - " & I & vbCrLf
Next I
wDNumb = InputBox("Please, choose the number of the word file from which you are choosing the data to copy:" & vbCrLf & _
vbCrLf & strD, "Choose the word document from which you are copying the data!", 1)
If wDNumb <= Documents.Count And wDNumb >= 1 Then
GoTo DSelection2
ElseIf wDNumb = "" Then MsgBox "Operation cancelled", vbCritical, "Cancelled"
Exit Sub
ElseIf wDNumb > Documents.Count Or wDNumb < 1 Then MsgBox "Wrong number, input a correct number", vbExclamation, "Wrong number"
Exit Sub
End If
DSelection2:
If IsNumeric(wDNumb) Then
Set DC = Documents(CLng(wDNumb))
Else
MsgBox "Please choose the number on the right of the document chosen!": GoTo DSelection
End If
End Sub
I have the following part of the code to copy some part of the Word to the other using bookmarks:
DC.Activate
Set Rng = DC.Range
With Rng.Find
.ClearFormatting
.Execute FindText:="TITLE:", Forward:=True, _
Format:=False, Wrap:=wdFindStop
Fnd = .Found
End With
If Fnd = True Then
With Rng
.MoveStart wdCharacter, 10
.MoveEnd wdSentence, 1
End With
End If
Rng.Select
Selection.Copy
wD.Activate
Selection.GoTo What:=wdGoToBookmark, Name:="TITLE"
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Paste
There are multiple possible ways of approaching this, but your problem description lacks sufficient detail. For example, one could insert:
bookmarks;
content controls;
Section breaks;
tables;
etc.,
into the target document so that content from the source document can be inserted there.
Alternatively, one might use Find/Replace to locate a predefined string that can be replaced with the desired content.
With your updated problem description, you might use:
Dim RngDC As Range, wDRng As Range, BkMkNm As String
BkMkNm "TITLE"
With DC
With .Range.Find
.ClearFormatting
.Execute FindText:=BkMkNm, Forward:=True, Format:=False, Wrap:=wdFindStop
End With
If .Found = True Then
.MoveStart wdCharacter, 10
.MoveEnd wdSentence, 1
Set RngDC = .Duplicate
End If
End With
With wD
Set wDRng = .Bookmarks(BkMkNm).Range
wDRng.FormattedText = RngDC.FormattedText
.Bookmarks.Add BkMkNm, wDRng
End With
'''
When I used the code below it works in the document where it was created. If I change documents, it fails. does anyone know why?
'''
'
Sub AddTOC() 'Need to find how to stop going in error on doc change
Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=0
Application.Templates( _
"C:\Users\Sean Celestin\AppData\Roaming\Microsoft\Document Building Blocks\1033\16\Built-In
Building Blocks.dotx" _
).BuildingBlockEntries("Automatic Table 1").Insert Where:=Selection.Range _
, RichText:=True
Selection.InsertBreak Type:=wdPageBreak
End Sub
'
The following code does essentially the same thing without embedding the Table of Contents in the container used by the Building Block Entry. That container imposes a significant performance hit when the TOC is updated. By not using Selection, the code is also more efficient.
Sub AddTOC()
Application.ScreenUpdating = False
With ActiveDocument
.Range(0, 0).Text = vbCr & Chr(12)
.Fields.Add .Range(0, 0), wdFieldEmpty, "TOC \o ""1-3"" \h \z \u", False
.Range(0, 0).Text = "Contents" & vbCr
.Range.Paragraphs.First.Style = "TOC Heading"
End With
Application.ScreenUpdating = True
End Sub
I have a document with several letters separated with section breaks.
What I want to do is to break the document into several ones containing X number of letters (without manually selecting them).
What I have done is to separate it into individual letters with one macro (BreakOnSection), and then combine them with another one (MergeMultiDocsIntoOne) that open a file browser and allows me to select the files I want manually. Below are the macros.
Main Question: If the main document is divided into, let's say, 100 smaller documents, is it possible to modify the second macro, so it selects automatically 10 of them from a folder, merges/combines them creating a new document, and then goes on with another batch of 10, and so on?
First macro:
Sub BreakOnSection()
'Criteria for moving through the document by section.
Application.Browser.Target = wdBrowseSection
'For i = 1 To ((ActiveDocument.Sections.Count) - 1)
For i = 1 To ActiveDocument.Sections.Count
'Copy the whole section
ActiveDocument.Bookmarks("\Section").Range.Copy
'Create a new document to paste text from the clipboard.
Documents.Add
Selection.Paste
'Removes the break that is copied at the end of the section, if any.
Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.Delete Unit:=wdCharacter, Count:=1
ChangeFileOpenDirectory "C:\Users\MyUser\Desktop\MyFolder"
DocNum = DocNum + 1
ActiveDocument.SaveAs Filename:="letter_" & DocNum & ".docx"
ActiveDocument.Close
'Move the selection to the next section
Application.Browser.Next
Next i
ActiveDocument.Close savechanges:=wdDoNotSaveChanges
'ActiveDocument.Close savechanges:=wdSaveChanges
End Sub
Second macro:
Sub MergeMultiDocsIntoOne()
Dim dlgFile As FileDialog
Dim nTotalFiles As Integer
Dim nEachSelectedFile As Integer
Set dlgFile = Application.FileDialog(msoFileDialogFilePicker)
With dlgFile
.AllowMultiSelect = True
If .Show <> -1 Then
Exit Sub
Else
nTotalFiles = .SelectedItems.Count
End If
End With
For nEachSelectedFile = 1 To nTotalFiles
Selection.InsertFile dlgFile.SelectedItems.Item(nEachSelectedFile)
If nEachSelectedFile < nTotalFiles Then
Selection.InsertBreak Type:=wdPageBreak
Else
If nEachSelectedFile = nTotalFiles Then
Exit Sub
End If
End If
Next nEachSelectedFile
End Sub
Instead of breaking all the Sections into separate documents before recombining them, you'd do far better to simply split the original document into however multi-Section blocks you need. The following code will split any multi-Section document that you might want to break into equal Section counts:
Sub SplitDocument()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, StrTxt As String
Dim Rng As Range, Doc As Document, HdFt As HeaderFooter
Const StrNoChr As String = """*./\:?|"
j = InputBox("How many Section breaks are there per output document?", "Split By Sections", 1)
With ActiveDocument
' Process each Section
For i = 1 To .Sections.Count - 1 Step j
With .Sections(i)
'*****
' Get the 1st paragraph
Set Rng = .Range.Paragraphs(1).Range
With Rng
' Contract the range to exclude the final paragraph break
.MoveEnd wdCharacter, -1
StrTxt = .Text
For k = 1 To Len(StrNoChr)
StrTxt = Replace(StrTxt, Mid(StrNoChr, k, 1), "_")
Next
End With
' Construct the destination file path & name
StrTxt = ActiveDocument.Path & "\" & StrTxt
'*****
' Get the whole Section
Set Rng = .Range
With Rng
If j > 1 Then .MoveEnd wdSection, j - 1
'Contract the range to exclude the Section break
.MoveEnd wdCharacter, -1
' Copy the range
.Copy
End With
End With
' Create the output document
Set Doc = Documents.Add(Template:=ActiveDocument.AttachedTemplate.FullName, Visible:=False)
With Doc
' Paste contents into the output document, preserving the formatting
.Range.PasteAndFormat (wdFormatOriginalFormatting)
' Delete trailing paragraph breaks & page breaks at the end
While .Characters.Last.Previous = vbCr Or .Characters.Last.Previous = Chr(12)
.Characters.Last.Previous = vbNullString
Wend
' Replicate the headers & footers
For Each HdFt In Rng.Sections(j).Headers
.Sections(j).Headers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
Next
For Each HdFt In Rng.Sections(j).Footers
.Sections(j).Footers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
Next
' Save & close the output document
.SaveAs FileName:=StrTxt & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
' and/or:
.SaveAs FileName:=StrTxt & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Next
End With
Set Rng = Nothing: Set Doc = Nothing
Application.ScreenUpdating = True
End Sub
Word document and PDF output are both catered for.
As coded, it is assumed the output filename consists of the first paragraph in each group of Sections. If not, you could use a different range or replace all of the content between the ***** strings with code like:
' Construct the destination file path & name
StrTxt = ActiveDocument.Path & "\" & (i + j - 1) / j
I am trying to create two keyboard shortcuts which allow me to move selected words quickly to the right and left within a text. The selected text should move one word to the left or the right.
Here is what I want to do
1) Select words e.g. “this is” in the sentence “this is a tree”
2) Press e.g. ctrl + alt + arrow to the right
3) The sentence reads now as “a this is tree”
4) Press again ctrl alt + arrow to the right
5) The sentence reads now as “a tree this is”
The idea is to replace the cut / paste steps and make the process a bit more efficient and smoother.
I have no knowledge in VB, but managed to get close to by using Word’s macro-function.
Sub moveRight()
'moveRight Macro
Selection.Cut
Selection.moveRight Unit:=wdWord, Count:=1
Selection.PasteAndFormat (wdFormatOriginalFormatting)
End Sub
The problem with this function is that the selected words are no longer selected once they are pasted. Hence, triggering the function again (=moving the text more than one word) results in an error (I would have to select the relevant text again). Is there any way that the selected words remain selected after they are pasted so that I can trigger the function repeatedly?
Many thanks.
You might like to try this solution. The first two procedures below should be called by your keyboard shortcuts. The both call the same executing sub, but with different parameters.
Sub MoveSelectionLeft()
' call with keyboard shortcut
GetSelection True
End Sub
Sub MoveSelectionRight()
' call with keyboard shortcut
GetSelection False
End Sub
Private Sub GetSelection(ByVal ToLeft As Boolean)
' 22 Apr 2017
Dim Rng As Range
Dim SelTxt As String ' selected text (trimmed)
Dim Sp() As String
Set Rng = Selection.Range
With Rng
SelTxt = Trim(.Text)
If ToLeft Then
.MoveStart wdWord, -1
Else
.MoveEnd wdWord, 1
End If
Sp = Split(Trim(.Text))
If ToLeft Then
.Text = SelTxt & " " & Sp(0) & " "
Else
.Text = Sp(UBound(Sp)) & " " & SelTxt & " "
End If
.Find.Execute SelTxt
.Select
End With
End Sub
A cheap way of doing this is with bookmarks. At some point before and after moving the text, run AddBookMark and DeleteBookMark respectively.
Public Sub AddBookMark()
Dim myDocument As Document
Set myDocument = ActiveDocument
myDocument.Bookmarks.Add "MySelectedText", Selection
End Sub
Public Sub DeleteBookMark()
Dim myDocument As Document
Set myDocument = ActiveDocument
myDocument.Bookmarks("MySelectedText").Delete
End Sub
Sub moveRight()
Dim myDocument As Document
Set myDocument = ActiveDocument
Selection.Cut
Selection.moveRight Unit:=wdWord, Count:=1
Selection.PasteAndFormat (wdFormatOriginalFormatting)
myDocument.Bookmarks("MySelectedText").Select
End Sub
I'm not quite familiar with VBA in general or working with Range. I'd like to add a checkbox after a line of text but the following code outputs all the checkboxes at the very end of the document. I'd think the range parameter in setting the checkbox needs to be fixed but I don't know how to identify it.
'http://wordribbon.tips.net/T010727_Inserting_Multiple_Graphics_in_a_Document.html
Sub GenerateLab()
Dim sPic As String
Dim sPath As String
sPath = "C:\Users\lab\Documents\PDF Gen 12-1\TestImages\"
sPic = Dir(sPath & "*.png")
Do While sPic <> ""
Selection.TypeText ("Is this an ***?")
Selection.TypeParagraph
Selection.TypeText ("***")
Dim objCC As ContentControl
Set objCC = ActiveDocument.ContentControls _
.Add(wdContentControlCheckBox)
Selection.TypeParagraph
Selection.TypeText ("Not ***")
Dim objCC2 As ContentControl
Set objCC2 = ActiveDocument.ContentControls _
.Add(wdContentControlCheckBox)
Selection.InlineShapes.AddPicture _
FileName:=sPath & sPic, _
LinkToFile:=False, SaveWithDocument:=True
sPic = Dir
Selection.InsertBreak (7)
Loop
End Sub
The problem is not that the checkbox is added at the end of the document but that it's added after the current selection/insertion point (which is the same as the end of the document). Then everything else is added in front of the box and it stays at the end. A short fix would be to move the cursor to the end of the line (or document) by adding the line
Selection.EndKey wdLine
or
Selection.EndKey wdStory
right after .Add.
Another possibility would be to move the cursor 3 characters to the right:
Selection.Move Unit:=wdCharacter, Count:=3
This would be an alternative if you don't add the checkbox at the end of a line.