I wrote a little script that exports certain Excel cell values into Word. However, certain inserts need to be bold. And there doesn't seem to be an easy way to do this.
This code loops through the records and adds them to the Word document
Do While intRow < intTotalRows + 1
strTemp = " ;b;" & Range("G" & intRow).FormulaR1C1 & " " & Range("I" & intRow).FormulaR1C1 & ";e; "
If strTemp <> strCur Then
strCur = strTemp
.Content.Font.Bold = True
.Content.InsertAfter strCur
End If
.Content.Font.Bold = False
.Content.InsertAfter Range("A" & intRow).FormulaR1C1 & " - " & Range("C" & intRow).FormulaR1C1 & " " & Range("E" & intRow).FormulaR1C1 & " * "
intRow = intRow + 1
Loop
Turning on bold before inserting text and turning it off again afterwards seems like the most logical solution, so it does not work.
I then tried to find and replace the text, but that also did not work:
.Content.Find.ClearFormatting
With .Content.Find
.Text = ";b;" 'Look for
.Replacement.Text = ";bbb;" 'Replace with
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
.Content.Find.Execute Replace:=wdReplaceAll
Replace .InsertAfter with .TypeText. Inserting works like pasting whereas TypeText works like if you would actually type the text on the keyboard.
Related
I'm trying to search specific words in the selected/highlighted text. The result should show how much the word is used throughout the highlighted selected area.
I wrote a macro, but the total value of words shown is calculated through the entire document, not the selected part.
Sub CountWords()
'macros for counting specific words in the document
'to count the number of a specified word, this word needs to be highlighted
Dim rng As Range
Dim sWord As String
Dim i As Long
Dim sWord As String
Set rng = Selection.Range
Application.ScreenUpdating = False
sWord = InputBox( _
Prompt:="What word do you want to count?", _
Title:="Count Words", Default:="")
With rng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = sWord
.Forward = True
.MatchWholeWord = True
.MatchWildcards = False
.Wrap = wdFindStop
Do While .Execute
i = i + 1
Loop
End With
Select Case i
Case 2 To 4
MsgBox "word " & Chr(171) & sWord & Chr(187) & " occurred in the document " & i & " times", _
vbInformation, "word count"
Case 1
MsgBox "word " & Chr(171) & sWord & Chr(187) & " occurred in the document " & i & " times", _
vbInformation, "word count"
Case Else
MsgBox "word " & Chr(171) & sWord & Chr(187) & " occurred in the document " & i & " times", _
vbInformation, "word count"
End Select
rng.Find.Text = ""
Application.ScreenUpdating = True
End Sub
I've tried a bunch of stuff, even other peoples codes. Every one of them counts specific words throughout the entire document.
For example:
Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range, sWord As String, i As Long
sWord = InputBox(Prompt:="What word do you want to count?", Title:="Count Words", Default:="")
With Selection
Set Rng = .Range
.Collapse wdCollapseStart
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = sWord
.Forward = True
.MatchWholeWord = True
.MatchWildcards = False
.Wrap = wdFindStop
End With
Do While .Find.Execute
If .InRange(Rng) = False Then Exit Do
i = i + 1
Loop
End With
End With
Rng.Select
MsgBox "The word " & Chr(171) & sWord & Chr(187) & " occurred " & i & " times in the selected range.", _
vbInformation, "word count"
Application.ScreenUpdating = True
End Sub
In the following code I am trying to insert a picuture into my word document based on the text I found while searchiung. The problem is it will only return to me the firsat character od the text. How do I get all of the text? How do I get the actual line it was found in? The text I am looking for is directly after the text found. IE: "Insert screen shot here of Boxshot" So I am trying to load a file called Boxshot. NOT working. Help.
Sub NewPic()
'
' NewPic Macro
'
Dim screenshot, Dirname, selfound As String
Dim Dn As Long
'
With Selection.Find
.Text = "Insert screen shot here of "
'.Replacement.Text = ""
.Forward = True
End With
Selection.Find.Execute
'
'Insert picture and find next match
'
While Selection.Find.Found
Selection.TypeParagraph
Selection.TypeParagraph
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.Select
selfound = Selection.Characters.First
MsgBox ("Text=" & selfound)
'
'Is picture there?
'
Dirname = ActiveDocument.Name
Dn = InStr(Dirname, "User")
Dirname = Left(Dirname, Dn)
screenshot = "C:\Users\User 1\Desktop\VB Upload files\CD's\" & Dirname & "\" &
Selection.Text & ".jpg"
MsgBox ("Screenshot= " & screenshot & ", Sellectedtext=" & Selection.Text)
'
If Dir(screenshot) <> "" Then
Else
screenshot = "C:\Users\User 1\Desktop\Mylogo.jpg"
End If
'
Selection.InlineShapes.AddPicture FileName:= _
screenshot, LinkToFile:=False, SaveWithDocument _
:=True
'"C:\Users\User 1\Desktop\Mylogo.jpg", LinkToFile:=False, SaveWithDocument _
':=True
Selection.TypeParagraph
Selection.TypeParagraph
Selection.MoveDown Unit:=wdParagraph, Count:=1
Selection.TypeParagraph
Selection.Find.Execute
Wend
'
End Sub
Your use of Selection makes your code unnecessarily complex and slow. The following macro will insert the relevant pictures wherever "Insert screen shot here of " is followed by the pic name (no error-checking for valid names & files). If you don't want to retain the pic names below the pics, simply un-comment the commented-out line.
Sub NewPics()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "Insert screen shot here of "
.Replacement.Text = ""
.Forward = True
.Format = False
.Wrap = wdFindContinue
End With
Do While .Find.Execute
.Text = vbCr
.Collapse wdCollapseEnd
.End = .Paragraphs.Last.Range.End - 1
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.InlineShapes.AddPicture FileName:=ActiveDocument.Path & "\" & .Text & ".jpg", LinkToFile:=False, SaveWithDocument:=True
'.Start = .Start + 1: .Delete
Loop
End With
Application.ScreenUpdating = True
End Sub
I am trying to find all of the cells with a certain text of "0.118" in column 2 of my table and do a list of commands for that row
I am also trying to take the value from column 5 of that selected text found in that row and subtract the value I put in the input box for that row.
The problem I am having is that it only changes one of my found "0.118" and not all of them in each row.
And I can't figure out how to search for the column(5) of that selected row.
Any help would be greatly appreciated.
Thank you.
Sub ConvertTo_3MM()
Dim oTable As Table
Dim stT As Long, enT As Long
Dim stS As Long, enS As Long
With Selection.Find
.Forward = True
.MatchPhrase = True
.Execute FindText:="0.118"
End With
For Each oTable In ActiveDocument.Tables
Do While Selection.Find.Execute = True
stT = oTable.Range.Start
enT = oTable.Range.End
stS = Selection.Range.Start
enS = Selection.Range.End
If stS < stT Or enS > enT Then Exit Do
Selection.Collapse wdCollapseStart
If ActiveDocument.Tables.Count >= 1 Then
With ActiveDocument.Tables(1).Cell(nRow, 2).Range
.Text = "3 MM" & vbCrLf & "-" & vbCrLf & "6 MM"
End With
End If
Selection.MoveRight Unit:=wdCell
If ActiveDocument.Tables.Count >= 1 Then
With ActiveDocument.Tables(1).Cell(nRow, 3).Range
.InsertAfter Text:=vbCrLf & "-" & vbCrLf & "SHANK"
End With
End If
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
response = InputBox("Cut Length For 3 MM")
If ActiveDocument.Tables.Count >= 1 Then
With ActiveDocument.Tables(1).Cell(nRow, 5).Range
.Text = response & vbCrLf & "-" & vbCrLf & (column(5).value - response)
End With
End If
Selection.Find.Execute Replace:=wdReplaceAll
Loop
Selection.Collapse wdCollapseEnd
Next
Application.ScreenUpdating = True
End Sub
I would be very surprised if the code in your question actually does anything as it doesn't even compile.
Your code is rather a confused mess so I'm not entirely certain that I have correctly understood what you are attempting to do, but try this:
Sub ConvertTo_3MM()
Application.ScreenUpdating = False
Dim oTable As Table
Dim response As String
For Each oTable In ActiveDocument.Tables
With oTable.Range
With .Find
.Forward = True
.MatchPhrase = True
.Text = "0.118"
.Wrap = wdFindStop
.Execute
End With
Do While .Find.Found = True
.Text = "3 MM" & vbCr & "-" & vbCr & "6 MM"
With .Rows(1)
.Cells(3).Range.InsertAfter Text:=vbCr & "-" & vbCr & "SHANK"
response = Val(InputBox("Cut Length For 3 MM"))
With .Cells(5).Range
.Text = response & vbCr & "-" & vbCr & (Val(.Text) - response)
End With
End With
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Next
Application.ScreenUpdating = True
End Sub
Thi may not be a solution, but I do see some problems:
You do:
For Each oTable In ActiveDocument.Tables
Then you do inside that loop:
Do While Selection.Find.Execute = True
but this Find will not be limited to the table of the For Each loop.
Though harmless, inside this Do While loop you do:
If ActiveDocument.Tables.Count >= 1 Then
but of course this is true because the For Each already determined there is at least 1 table.
I suggest you lookup the documentation of Find, rethink the logic and then run it step by step in the debugger to see what the code is doing.
Try this code:
Sub ConvertTo_3MM()
Dim oTable As Table, rng As Range
Dim nRow As Long, response As String
For Each oTable In ActiveDocument.Tables
With oTable
Set rng = .Range
Do
If rng.Find.Execute("0.118") Then
If rng.Information(wdEndOfRangeColumnNumber) = 2 Then
nRow = rng.Information(wdEndOfRangeRowNumber)
.Cell(nRow, 2).Range.Text = "3 MM" & vbCrLf & "-" & vbCrLf & "6 MM"
.Cell(nRow, 3).Range.InsertAfter Text:=vbCrLf & "-" & vbCrLf & "SHANK"
response = Val(InputBox("Cut Length For 3 MM"))
.Cell(nRow, 5).Range.Text = response & _
vbCrLf & "-" & vbCrLf & (Val(.Cell(nRow, 5).Range.Text) - response)
End If
Else
Exit Do
End If
rng.Collapse wdCollapseEnd
Loop
End With
Next
Application.ScreenUpdating = True
End Sub
Before
After
I have a table in access that holds paragraphs for letters to go to customers. Each letter have a number of paragraphs.
On our server there is the template document.
I use the code below to paste (in 240 character batches because anything larger generates a "too many characters" error message)
It all works fine except that except for the first line of each paragraph, every line is indented by a space.
I have recreated the word template. I have checked paragraphs and alignment in word. There are no tab stops either.
I am using windows 10, office 2010, access 2010 front end, sql server back end
One paragraph is too large and is split in 2, but when transferred the join point (in the middle of a word) looks fine.
Code is
'3. Build letter text
sPara1 = DLookup("CorroParagraphText", "t_CorroParagraph", "([CPCorroTemplateid] = " & iCorroTemplate & ") and ([CorroParagraphNumber] = " & iPara & ")")
iPara = iPara + 1
sPara2 = DLookup("CorroParagraphText", "t_CorroParagraph", "([CPCorroTemplateid] = " & iCorroTemplate & ") and ([CorroParagraphNumber] = " & iPara & ")")
iPara = iPara + 1
sPara3 = DLookup("CorroParagraphText", "t_CorroParagraph", "([CPCorroTemplateid] = " & iCorroTemplate & ") and ([CorroParagraphNumber] = " & iPara & ")")
'3a. replace strings where needed
sPara1 = replace(sPara1, "[Address]", sSendTo)
sPara1 = replace(sPara1, "[Date]", Format(date, "dd/mm/yyyy"))
'20180117 MO - using alot of Dlookups for practice!
sName = Nz(DLookup("PersTitle", "t_Person", "PersonId = " & iMainPOCPersonId), "")
sName = sName & " " & Nz(DLookup("PersSurname", "t_Person", "PersonId = " & iMainPOCPersonId), "")
sPara1 = replace(sPara1, "[Name]", sName & ",")
sPara1 = replace(sPara1, "[FEC ID]", iFECRef)
sLeadName = DLookup("StaffName", "Staff", "[ID] =" & iLeadStaffId)
sLeadName = sLeadName & " " & DLookup("StaffSurname", "Staff", "[ID] =" & iLeadStaffId)
sLeadJobTitle = DLookup("JobTitle", "Staff", "[ID] =" & iLeadStaffId)
sLeadEmail = DLookup("StaffEmail", "Staff", "[ID] =" & iLeadStaffId)
sLeadStaff = sLeadName & vbCrLf & sLeadJobTitle & vbCrLf & sLeadEmail
sPara3 = replace(sPara3, "[LeadStaff]", sLeadStaff)
strCorroAttach = DLookup("CTAAttachment", "t_CorroTemplateAttachment", "[CTACorroTemplateID] = " & iCorroTemplate)
sContent = sPara1 & vbCrLf & sPara2 & vbCrLf & sPara3
'4. PDF and save letter in customer folder with copy of complaint procedure
'this is where the draft leter will be saved.
DirName = "P:\General Enquiries\Customer_Files\ID " & Format(iFECRef, "0000")
DirContracts = DirName & "\Contracts"
DirOther = DirName & "\Other Info"
DirRenewables = DirName & "\Renewables"
'create the directory if it doesn't exist
If Dir(DirName, vbDirectory) = "" Then
MkDir DirName
MkDir DirContracts
MkDir DirOther
MkDir DirRenewables
End If
'this is the template that is used to create the letter
strWordTemplate = "P:\Office templates\Whole office\General Templates\FEC Letter NFU.dotx"
strWordVersion = DirName & "\ComplaintID" & iComplaintID & "-" & Format(Now, "yyyymmdd") & ".doc"
' open a new instance of word
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
' open the template
Set wrdDoc = wrdApp.Documents.Open(strWordTemplate)
wrdDoc.SaveAs FileName:=strWordVersion, FileFormat:=0
wrdDoc.ActiveWindow.Activate
wrdDoc.ActiveWindow.SetFocus
Set wrdSel = wrdDoc.ActiveWindow.Selection
wrdSel.Find.ClearFormatting
wrdSel.Find.Replacement.ClearFormatting
'PARA 1
'20180123 MO - needed to find a way to paste in the other paras longer than 255
'which is why this loop is here
sContent = sPara1
iParaLength = Len(sContent)
iReplaceLoopCounter = 1
Do While (iParaLength > 0)
sContentTemp = Mid(sContent, (iReplaceLoopCounter * 240) - 239, 240)
sContentTemp = sContentTemp & "[Start Here]"
With wrdSel.Find
.Text = "[Start here]"
.Replacement.Text = sContentTemp
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
'Debug.Print sContentTemp
wrdSel.Find.Execute replace:=wdReplaceAll
iParaLength = iParaLength - (iReplaceLoopCounter * 240)
iReplaceLoopCounter = iReplaceLoopCounter + 1
If iParaLength < 0 Then Exit Do
Loop
'PARA 2
sContent = vbCrLf & vbCrLf & sPara2
iParaLength = Len(sContent)
iReplaceLoopCounter = 1
Do While (iParaLength > 0)
sContentTemp = Mid(sContent, (iReplaceLoopCounter * 240) - 239, 240)
sContentTemp = sContentTemp & "[Start Here]"
With wrdSel.Find
.Text = "[Start here]"
.Replacement.Text = sContentTemp
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
'Debug.Print sContentTemp
wrdSel.Find.Execute replace:=wdReplaceAll
iParaLength = iParaLength - (iReplaceLoopCounter * 240)
iReplaceLoopCounter = iReplaceLoopCounter + 1
If iParaLength < 0 Then Exit Do
Loop
'PARA 3
sContent = vbCrLf & vbCrLf & sPara3
iParaLength = Len(sContent)
iReplaceLoopCounter = 1
Do While (iParaLength > 0)
sContentTemp = Mid(sContent, (iReplaceLoopCounter * 240) - 239, 240)
sContentTemp = sContentTemp & "[Start Here]"
With wrdSel.Find
.Text = "[Start here]"
.Replacement.Text = sContentTemp
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
'Debug.Print sContentTemp
wrdSel.Find.Execute replace:=wdReplaceAll
iParaLength = iParaLength - (iReplaceLoopCounter * 240)
iReplaceLoopCounter = iReplaceLoopCounter + 1
If iParaLength < 0 Then Exit Do
Loop
'get rid of the last [Start Here]
sContentTemp = ""
With wrdSel.Find
.Text = "[Start here]"
.Replacement.Text = sContentTemp
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
wrdSel.Find.Execute replace:=wdReplaceAll
'save temp file to customer folder
strWordTemplateTemp = DirName & "\ComplaintID" & iComplaintID & "-" & Format(Now, "yyyymmdd") & ".pdf"
ActiveDocument.ExportAsFixedFormat OutputFileName:= _
strWordTemplateTemp, ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=True, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
wdExportAllDocument, From:=1, To:=1, Item:=wdExportDocumentContent, _
IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:= _
wdExportCreateNoBookmarks, DocStructureTags:=True, BitmapMissingFonts:= _
True, UseISO19005_1:=False
Thanks - I appreciate any help. This is my first post.
My first suggestion is the VBA command Trim (e.g. ValidPara = Trim(sPara)). Trim will remove the trailing and leading whitespace from your paragraph. However, it will also convert multiple spaces inside the paragraph to single spaces. This should be acceptable for your case.
Extending on this is the VBA command LTrim (e.g. ValidPara = LTrim(sPara)). This only removes the leading spaces and is probably the most appropriate for what you want to do.
Another option is a little more complicated. For this example I am assuming there is only one invalid space in front of the paragraph
If Left(sPara,1) = " " Then
ValidPara = Right(sPara, Len(sPara)-1) ' removes first character from string
End If
If you have multiple spaces in front of the paragraph, then you can change the If-End If statement to a While-Wend loop. In addition, the above code can be modified to strip other strange characters if you ever find yourself in that situation.
thank you for your help and advice. Trimming spaces from the front of the paragraph did not solve the problem, but pointed to what the problem was.
I had to replace "vbcrlf" in my access vba code with "Chr(10) & Chr(13) & ", but I also had to replace "Chr(13) & Chr(10) & " with "Chr(10) & Chr(13) & " for each string I pulled from the access table. The paragraphs in the table had returns and by identifying the characters' ascii code they came out as 13 then 10. Switching them around eliminated the leading space.
I don't think I properly described the issue and i should have added an example of the output - this would have made what was going on clearer. And as Mat's Mug pointed out I should have reduced the code I posted.
I am writing my essays for university and I am not allowed to include words used in quotes toward my total word count. As Word does not have a feature to do this i was hoping that someone would be able to help me by creating a macro. I have used macros before, but I have very, very little experience into something as complex as this (if it's even that complex).
I already have something similar to work with citations throughout a document and so having both of these will be a great help. I will copy this code below so you can get a rough idea of what I need, except with quotes instead of citations.
So I was wondering if someone would be able to produce a macro that counted the number of words used in quotes throughout a document?
Sub CitationWordCount()
Dim Fld As Field, l As Long, StrTmp As String
For Each Fld In ActiveDocument.Fields
With Fld
If .Type = wdFieldCitation Then
StrTmp = .Result
l = l + UBound(Split(StrTmp, " ")) + UBound(Split(StrTmp, "-")) + 1
StrTmp = .Code.Text
l = l + Len(StrTmp) - Len(Replace(StrTmp, "\n", "\"))
End If
End With
Next
MsgBox "There are " & l & " words in citations in this document.", , "Citation Word Count"
End Sub
Paul Edstein (macropod) wrote a solution to this issue months ago on http://www.msofficeforums.com/word-vba/33866-count-words-between-quotation-marks.html
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, j As Long
With ActiveDocument
j = .ComputeStatistics(wdStatisticWords)
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "[“" & Chr(34) & "]*[" & Chr(34) & "”]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
i = i + .ComputeStatistics(wdStatisticWords)
.Collapse wdCollapseEnd
.Find.Execute
Loop
MsgBox "This document contains " & j & " words ," & vbCr & _
"of which " & i & " (" & Format(i * 100 / j, "0.00") & _
"%) are in quotes."
End With
End With
Application.ScreenUpdating = True
End Sub
This will give you your total word count and the total amount of words in quotation marks. To get your total number, just subtract the words in quotes from the total words.