The test code below examines paragraphs in ActiveDocument and puts 'copies' of unique paragraphs at the bottom of the document, followed by their original spacing blank paragraphs. Paragraphs are manipulated in an array, and qualifying paragraphs are then added one by one to the bottom of that document. Is there a faster way of adding those paragraphs there? I am hoping there is a way to add the array directly without needing the loop. I think that it is possible to assign an array to a range in Excel (see Rick Rothstein), but I can't see how to do that in Word 2010.
Sub FullArray()
Dim StartTime 'Start time
Dim p As Paragraph 'is each initial paragraph object in ActiveDocument
Dim pDict As New Scripting.Dictionary 'Keys=plain text versions of each inital para
'Items=signifiers of each key's (and para's)uniqueness or otherwise
Dim t As String 'Plain text version of each p, being a key of pDict
Dim pArray(1000) As Variant 'Contains all initial paragraph objects
Dim c As Integer 'c is ordinal number of each element of pArray
Dim dky As String 'dky is whichever element of pArray is to be used as a key of pDict
Dim pc As Integer 'running count of plain text paras in pDict
Dim lastdky As Integer 'signifies whether previous key of pDict is unique
'faster when dimmed, option explicit
StartTime = Timer
Application.ScreenUpdating = False 'Line 1 of Go to end of doc
ActiveDocument.Characters.Last.Select 'Line 2 of Go to end of doc. Is there a Faster way?
Selection.Collapse
'ADD each para object to Array. Write its plain text to dictionary...
'...in order to determine uniqueness of each para.
For Each p In ActiveDocument.Paragraphs
t = p.Range.Text
If Not pDict.Exists(t) Then
pDict.Add Key:=t, Item:=1 '1 flag means 1st instance of a para, including blamk paras
Else: pDict(t) = 2 '2 flag means a para which has duplicates
End If
pc = pc + 1 'count plain text paras in pDict
pArray(pc) = p 'set element number pc of Array = current paragraph object
Next p
'PLACE copies of certain paras at the end of document...
'...being those content-containing paras which were initially unique....
'...and place after each such para any following contiguous blank paras
lastdky = 1 '2/1 means PREVIOUS initial paragraph had/had not dupes.
For c = pc - 1 To 1 Step -1
dky = pArray(c)
If pDict(dky) = 1 And pArray(c) <> Chr(13) Then Selection.FormattedText = pArray(c) 'place para with content ('content paras') at end
If pArray(c) = Chr(13) And lastdky = 1 Then Selection.FormattedText = pArray(c) 'place (only) blank paras following content paras at end
If pDict(dky) = 2 Then lastdky = 2 Else: lastdky = 1
Next c
MsgBox "This code ran successfully in " & Round(Timer - StartTime, 2) & " seconds", vbInformation
Application.ScreenUpdating = True
End Sub
Related
I am creating a third party add in for my CAD program that has a sub in it that goes through a drawing and finds all the parts lists (BOMS), if any items in the parts list are shared between the BOM (1 part being used in 2 weldments for example) then it changes the item number of the second instance to be that of the first instance. It does this by comparing full file names between the two values. When they match change the number to that of the matcher. I have got this to work but it runs a little slow because for a 100 item BOM each item is compared to 100 and thus that takes a little longer then I would like (about 60seconds to run). After thinking about it I realized I did not need to compare each item to all the items, I just needed to compare until it found a duplicate and then exit the search loop and go to the next value. Example being Item 1 does not need to compare to the rest of the 99 values because even if it does have a match in position 100 I do not want to change item 1s number to that of item 100. I want to change item 100 to that of 1(ie change the duplpicate to that of the first encountered double). For my code however I am having trouble exiting the comparison for loops which is causing me trouble. An example of the trouble is this:
I have 3 BOMs, each one shares Part X, and is numbered 1 in BOM 1, 4 in BOM 2, and 7 in BOM 3. when I run my button because I cannot get it to leave the comparison loop once it finds it first match all the Part X's ended up getting item number 7 from BOM 3 because it is the last instance. (I can get this to do what I want by stepping through my for loops backwards and thus everything ends up as the top most occurrence, but I would like to get my exit fors working because it saves me on unnecessary comparisons)
How do I go about breaking out of the nested for loops using an if conditional?
Here is my current code:
Public Sub MatchingNumberR1()
Debug.Print ThisApplication.Caption
'define active document as drawing doc. Will produce an error if its not a drawing doc
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
'Store all the sheets of drawing
Dim oSheets As Sheets
Set oSheets = oDrawDoc.Sheets
Dim oSheet As Sheet
'Loop through all the sheets
For Each oSheet In oSheets
Dim oPartsLists As PartsLists
Set oPartsLists = oSheet.PartsLists
'Loop through all the part lists on that sheet
Dim oPartList As PartsList
'For every parts list on the sheet
For Each oPartList In oPartsLists
For i3 = 1 To oPartList.PartsListRows.Count
'Store the Item number and file referenced in that row to compare
oItem = FindItem(oPartList)
oDescription = FindDescription(oPartList)
oDescripCheck = oPartList.PartsListRows.Item(i3).Item(oDescription).Value
oNumCheck = oPartList.PartsListRows.Item(i3).Item(oItem).Value
'Check to see if the BOM item is a virtual component if it is do not try and get the reference part
If oPartList.PartsListRows.Item(i3).ReferencedFiles.Count = 0 Then
oRefPart = " "
End If
'Check to see if the BOM item is a virtual component if it is try and get the reference part
If oPartList.PartsListRows.Item(i3).ReferencedFiles.Count > 0 Then
oRefPart = oPartList.PartsListRows.Item(i3).ReferencedFiles.Item(1).FullFileName
End If
MsgBox (" We are comparing " & oRefPart)
'''''Create a comparison loop to go through the drawing that checks the oRefPart against other BOM items and see if there is a match.'''''
'Store all the sheets of drawing
Dim oSheets2 As Sheets
Set oSheets2 = oDrawDoc.Sheets
Dim oSheet2 As Sheet
'For every sheet in the drawing
For Each oSheet2 In oSheets2
'Get all the parts list on a single sheet
Dim oPartsLists2 As PartsLists
Set oPartsLists2 = oSheet2.PartsLists
Dim oPartList2 As PartsList
'For every parts list on the sheet
For Each oPartList2 In oPartsLists2
oItem2 = FindItem(oPartList2)
oDescription2 = FindDescription(oPartList2)
'Go through all the rows of the part list
For i6 = 1 To oPartList2.PartsListRows.Count
'Check to see if the part is a not a virtual component, if not, get the relevent comparison values
If oPartList2.PartsListRows.Item(i6).ReferencedFiles.Count > 0 Then
oNumCheck2 = oPartList2.PartsListRows.Item(i6).Item(oItem2).Value
oRefPart2 = oPartList2.PartsListRows.Item(i6).ReferencedFiles.Item(1).FullFileName
'Compare the file names, if they match change the part list item number for the original to that of the match
If oRefPart = oRefPart2 Then
oPartList.PartsListRows.Item(i3).Item(1).Value = oNumCheck2
''''''''This is where I want it to exit the loop and grab the next original value'''''''
End If
'For virtual components get the following comparison values
ElseIf oPartList2.PartsListRows.Item(i6).ReferencedFiles.Count = 0 Then
oNumCheck2 = oPartList2.PartsListRows.Item(i6).Item(oItem2).Value
oDescripCheck2 = oPartList2.PartsListRows.Item(i6).Item(oDescription2).Value
'Compare the descriptions and if they match change the part list item number for the original to that of the match
If oDescripCheck = oDescripCheck2 Then
oPartList.PartsListRows.Item(i3).Item(1).Value = oNumCheck2
''''''''This is where I want it to exit the loop and grab the next original value'''''''
End If
Else
''''''''This is where if no matches were found I want it to continue going through the comparison loop'''''''
End If
Next
Next
Next
Next
Next
Next
'MsgBox ("Matching Numbers has been finished")
End Sub
For escape from nested for loop you can use GoTo and specify where.
Sub GoToTest()
Dim a, b, c As Integer
For a = 0 To 1000 Step 100
For b = 0 To 100 Step 10
For c = 0 To 10
Debug.Print vbTab & b + c
If b + c = 12 Then
GoTo nextValueForA
End If
Next
Next
nextValueForA:
Debug.Print a + b + c
Next
End Sub
Here are a few examples that demonstrate (1) breaking out of (exiting) a loop and (2) finding the values in arrays.
The intersection of 2 arrays example can be modified to meet your need to "Create a comparison loop to go through the drawing that checks the oRefPart against other BOM items and see if there is a match." Note, you may find multiple matches between 2 arrays.
Option Explicit
Option Base 0
' Example - break out of loop when condition met.
Public Sub ExitLoopExample()
Dim i As Integer, j As Integer
' let's loop 101 times
For i = 0 To 100:
j = i * 2
'Print the current loop number to the Immediate window
Debug.Print i, j
' Let's decide to break out of the loop is some
' condition is met. In this example, we exit
' the loop if j>=10. However, any condition can
' be used.
If j >= 10 Then Exit For
Next i
End Sub
' Example - break out of inner loop when condition met.
Public Sub ExitLoopExample2()
Dim i As Integer, j As Integer
For i = 1 To 5:
For j = 1 To 5
Debug.Print i, j
' if j >= 2 then, exit the inner loop.
If j >= 2 Then Exit For
Next j
Next i
End Sub
Public Sub FindItemInArrayExample():
' Find variable n in array arr.
Dim intToFind As Integer
Dim arrToSearch As Variant
Dim x, y
intToFind = 4
arrToSearch = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
x = FindItemInArray(FindMe:=intToFind, _
ArrayToSearch:=arrToSearch)
If IsEmpty(x) Then
Debug.Print intToFind; "not found in arrToSearch"
Else
Debug.Print "found "; x
End If
intToFind = 12
y = FindItemInArray(FindMe:=intToFind, _
ArrayToSearch:=arrToSearch)
If IsEmpty(y) Then
Debug.Print intToFind; "not found in arrToSearch"
Else
Debug.Print "found "; y
End If
End Sub
Public Function FindItemInArray(FindMe, ArrayToSearch As Variant):
Dim i As Integer
For i = LBound(ArrayToSearch) To UBound(ArrayToSearch)
If FindMe = ArrayToSearch(i) Then
FindItemInArray = ArrayToSearch(i)
Exit For
End If
Next i
End Function
' Create a comparison loop to go through the drawing that checks
' the oRefPart against other BOM items and see if there is a match.
Public Sub ArrayIntersectionExample():
Dim exampleArray1 As Variant, exampleArray2 As Variant
Dim arrIntersect As Variant
Dim i As Integer
' Create two sample arrays to compare
exampleArray1 = Array(1, 2, 3, 4, 5, 6, 7)
exampleArray2 = Array(2, 4, 6, 8, 10, 12, 14, 16)
' Call our ArrayIntersect function (defined below)
arrIntersect = ArrayIntersect(exampleArray1, exampleArray2)
' Print the results to the Immediate window
For i = LBound(arrIntersect) To UBound(arrIntersect)
Debug.Print "match " & i + 1, arrIntersect(i)
Next i
End Sub
Public Function ArrayIntersect(arr1 As Variant, arr2 As Variant) As Variant:
' Find items that exist in both arr1 and arr2 (intersection).
' Return the intersection as an array (Variant).
Dim arrOut() As Variant
Dim matchIndex As Long
Dim i As Long, j As Long
' no matches yet
matchIndex = -1
' begin looping through arr1
For i = LBound(arr1) To UBound(arr1)
' sub-loop for arr2 for each item in arr1
For j = LBound(arr2) To UBound(arr2)
' check for match
If arr1(i) = arr2(j) Then
' we found an item in both arrays
' increment match counter, which we'll
' use to size our output array
matchIndex = matchIndex + 1
' resize our output array to fit the
' new match
ReDim Preserve arrOut(matchIndex)
' now store the new match our output array
arrOut(matchIndex) = arr1(i)
End If
Next j
Next i
' Have the function return the output array.
ArrayIntersect = arrOut
End Function
I have a macro that loops through an unknown number of times. The number of times varies based on a total number of rows in multiple tables in a reference document, and that number of rows will vary across reference documents that may be used. The relevant snippet of code for the loop is below:
For Each oRow In oTbl.Rows
p = p + 1
Helper.ProgressIndicator_Code (p)
strPhrase = Split(Trim(oRow.Range.Cells(1).Range.Text), vbCr)(0)
strRule = Split(Trim(oRow.Cells(2).Range.Text), vbCr)(0)
If strPhrase <> "" Then
If Not strStartWord = vbNullString Then
'Process defined sections
arrEndWords = Split(strEndWord, "|")
For lngIndex = 0 To UBound(arrEndWords)
Set oRng = GetDocRange(strStartWord, arrEndWords(lngIndex))
If Not oRng Is Nothing Then Exit For
Next lngIndex
Else
'Process whole document
Set oRng = m_oDocCurrent.Range
End If
If Not oRng Is Nothing Then
Set oRngScope = oRng.Duplicate
With oRng.Find
.Text = strPhrase
Do While .Execute
If Not oRng.InRange(oRngScope) Then Exit For
oRng.HighlightColorIndex = wdTurquoise
If strRule <> "" Then
Set oComment = m_oDocCurrent.Comments.Add(Range:=oRng, Text:=strUsr & ": " & strRule)
oComment.Author = UCase("WordCheck")
oComment.Initial = UCase("WC")
End If
Loop
End With
End If
End If
Next oRow
The progress bar is a classic progress bar for which a label field width is updated using the below code based on a value of p as updated in the above code:
Sub progress(pctCompl As Integer)
ProgressIndicator.Text.Caption = pctCompl & "% Completed"
ProgressIndicator.Bar.Width = pctCompl * 2
DoEvents
End Sub
Here's my problem: The value of p varies based on which reference document is used, so my progress bar is never even approximately accurate with respect to the processing of the VBA macro. The progress bar doesn't have to be exact, merely close and to indicate that progress is being made and nothing has hung.
I'm not looking for written code, just would be very grateful for suggestions or advice as to approaches for making my progress bar more accurate so that I can learn (e.g., I just ran the macro for three different reference documents - one gave me 25%, one gave 44%, and one gave 82%; none showed even close to 100% when completed). Essentially I need to divide i by an unknown number to get my percentage, which is clearly impossible, so some function for a close approximation is needed.
Edit: New code based on #macropod suggestion.
Dim strCheckDoc As String, docRef As Document, projectPath As String, _
j As Integer, i As Integer, k As Integer, oNumRows as Long
j = 1
For i = 0 To UBound(strUsr)
strCheckDoc = [path to reference document unique to each strUsr]
Set docRef = Documents.Open(strCheckDoc, ReadOnly:=True, Visible:=False)
For k = 1 To docRef.Tables.Count
oNumRows = oNumRows + docRef.Tables(i).Rows.Count
Next k
Next i
Then the code to update the progress bar is:
Dim pctCompl As Single
pctCompl = Round((p / oNumRows) * 100)
ProgressIndicator.Text.Caption = pctCompl & "% Completed"
ProgressIndicator.Bar.Width = pctCompl * 2
DoEvents
The progress bar now gets to 64% when complete (i.e., it should be at 100%). I'm also working on a way to make oNumRows only count a row if the row has content in the first column.
So I have been trying to make every 3 words in a word docuemnt bold in a specific selection or if there is nothing selected every 3 words in the whole document. I tried different approaches but nothing worked.
I should say "What have you tried so far?" and "Lets see your code.", but I haven't really coded in Word so thought I'd give it a go....
This seems to do the trick, although there may be a much better way to code it:
Public Sub BoldText()
Dim wrd As Range
Dim x As Long
Dim doc As Variant
If Selection.Start = Selection.End Then
Set doc = ThisDocument
Else
Set doc = Selection
End If
x = 0
For Each wrd In doc.Words
x = x + 1
If x Mod 3 = 0 Then
wrd.Bold = True
End If
Next wrd
End Sub
I have a spreadsheet with a column of cells that each contain several paragraphs of text. I'm trying to write a macro that will grab several sentences between these text phrases "How we made our decision" and "Conclusion"
The location of this text string varies from sheet to sheet but the column is always consistent.
I've been able to find a bunch of vba scripts that allow me to find and copy 1 word at a time or simple batches of single word. I'm just not able to figure our or find something that allows me to copy an entire paragraph from within a single cell of paragraphs.
The code below just grabs the entire table. As you can see in the beginning portion I was able to get what I need however I found out that the (70) is irrelevant because the table size changes with each pull of the record.
Sub GetTheData()
Dim T As String
Dim SWs As New SHDocVw.ShellWindows
Dim IE As SHDocVw.InternetExplorer
Dim LetPr As InternetExplorer
Dim Doc As HTMLDocument
'Dim IE As Object
Dim tbls, tbl, trs, tr, tds, td, r, c
For Each IE In SWs
If IE.LocationName = "Letter Preparation Case Summary – Member Case" Then
Set LetPr = IE
'LetPr.document.getElementById
T = IE.document.getElementsByTagName("td")(70).innerText
'T = Trim(Mid(T, InStr(T, "How We Made Our Decision: ") + 0, InStr(T, "Conclusion") - (InStr(T, "How We Made Our Decision:") + 26)))
Exit For
End If
Next
Set tbls = IE.document.getElementsByTagName("table")
For r = 0 To tbls.Length - 1
Debug.Print r, tbls(r).Rows.Length
Next r
Set tbl = IE.document.getElementsByTagName("table")(9)
Set trs = tbl.getElementsByTagName("tr")
For r = 0 To trs.Length - 1
Set tds = trs(r).getElementsByTagName("td")
'if no <td> then look for <th>
If tds.Length = 0 Then Set tds = trs(r).getElementsByTagName("th")
For c = 0 To tds.Length - 1
ActiveSheet.Range("A1").Offset(r, c).Value = tds(c).innerText
Next c
Next r
End Sub
You stated that you wanted the text 'between these text phrases' so the beginning position of the found text will have to be adjusted by hte length of the searched string.
dim beginStr as string, endStr as string, beginPos as long, endPos as long
beginStr = "How We Made Our Decision:"
endStr = "Conclusion"
beginPos = instr(1, T, beginStr, vbtextcompare)
endPos = instr(beginPos, T, endStr, vbtextcompare)
if cbool(beginPos) and cbool(endPos) then
beginPos = beginPos + len(beginStr)
T = Trim(Mid(T, beginPos, endPos - beginPos))
end if
That last endPos - beginPos might have to be adjusted by subtracting 1.
I have some bullets in a MS Word Document type wdListSimpleNumbering, I am unable to find a way to select all the paragraphs between bullets u) and v).
E.g. In the document, I have following bullets;
u) Company Introduction.
1st paragraph
2nd paragraph
3rd paragraph
v) Company Vision
Now I am looking a way to select the paragraphs between the bullets u) and v).
With the following code; I can select the text with bullet u) but not sure how to select range up till bullet v). Here is my code:
For Each oPara In ActiveDocument.Paragraphs
If oPara.Range.ListFormat.ListType = wdListSimpleNumbering And _
oPara.Range.ListFormat.ListString = "u)" Then _
oPara.Range.Font.ColorIndex = wdRed
oPara.Range.Select ' here I want to select paragraphs
Debug.Print (oPara)
End If
Next
Here's one way:
Sub TestSelectList()
Dim oPara As Paragraph
Dim bSelected As Boolean
For Each oPara In ActiveDocument.Paragraphs
If oPara.Range.ListFormat.ListType = wdListSimpleNumbering And _
oPara.Range.ListFormat.ListString = "u)" Then ' Make sure to remove underscore for a multiline THEN.
oPara.Range.Font.ColorIndex = wdRed
oPara.Range.Select
' Set a flag indicating that you are currently within the desired list item.
bSelected = True
Debug.Print (oPara)
ElseIf bSelected And oPara.Range.ListFormat.ListType <> wdListSimpleNumbering Then
' If the flag is positive and the current paragraph is not of the simple list type, include it in the selection.
Selection.MoveEnd wdParagraph
ElseIf oPara.Range.ListFormat.ListType = wdListSimpleNumbering Then
' Otherwise, if the paragraph is of the simple list type, turn off the flag.
bSelected = False
End If
Next
End Sub
This doesn't deal with situations where u) is the last item in the list, but I'm not sure what you'd want to do there, or how you'd know.