I am trying to make the Excel VBA search in a Word Document from page 5 onwards and once it finds the specific keyword it should target just the 1st encountered table and get some cells from the Word Table back to Excel as the code below will display. I am trying to introduce your Option1 in it but at the moment I can't. Any idea why?
Option Explicit
Sub Testt()
Dim ws As Worksheet
Dim Selection As Object
Dim objWord As Word.Application
Dim i As Integer
Dim strValue As String
Dim wdDoc As Word.Document
Dim wdFileName As Variant
Dim TableNo As Integer 'table number in Word
Dim myTableRange As Word.Range ' formerly variable 'a'
Dim oWordApp As Object, oWordDoc As Object
Dim pgNo As Long
Dim FlName As String
Dim SearchText As String
Dim IopenedWord As Boolean
Const wdMainTextStory As Integer = 1
Const wdActiveEndPageNumber As Integer = 3
Const wdStory As Integer = 6
Const wdFindContinue As Integer = 1
Set objWord = New Word.Application
Set wdDoc = objWord.Documents.Open("C:\Users\Nigel\Desktop\Testt.docx")
objWord.Visible = True
With wdDoc.StoryRanges(wdMainTextStory)
With .Find
.Forward = True
.ClearFormatting
.MatchWholeWord = True
.MatchCase = True
.Wrap = wdFindContinue
.Text = "Test"
.Execute
Do While objWord.Selection.Find.Execute = True
'~~> Get the page number
pgNo = objWord.Selection.Information(wdActiveEndPageNumber)
'~~> Check if the page number is >= 5
If pgNo >= 5 Then
Debug.Print "Search text found in page " & pgNo
End If
Loop
End With
If .Find.Found Then
MsgBox "Found"
Else
MsgBox "Not found"
Exit Sub
End If
Set myTableRange = .Duplicate.Next(unit:=wdTable)
Dim rowNb As Long
Dim ColNb As Long
Dim x As Long
Dim y As Long
x = 8
y = 1
With myTableRange.Tables(1)
For rowNb = 1 To 1 '
For ColNb = 2 To 2
Cells(x, y) = WorksheetFunction.Clean(.Cell(rowNb, ColNb).Range.Text)
y = y + 1
Next ColNb
y = 1
x = x + 1
Next rowNb
End With
x = x + 2
End With
End Sub
In the comments above, I mentioned 3 ways to achieve what you want. I am sure there are other ways as well to skin a cat.
Here is an example (Option 1) on how to search for a text from page 5 onwards. I have commented the code. Still if you do not understand then feel free to leave a comment and if I can reply, I will.
Option Explicit
Const wdMainTextStory As Integer = 1
Const wdActiveEndPageNumber As Integer = 3
Const wdStory As Integer = 6
Const wdFindContinue As Integer = 1
Sub Sample()
Dim oWordApp As Object, oWordDoc As Object
Dim pgNo As Long
Dim FlName As String
Dim SearchText As String
Dim IopenedWord As Boolean
'~~> Establish an Word application object
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set oWordApp = CreateObject("Word.Application")
IopenedWord = True
End If
Err.Clear
On Error GoTo 0
oWordApp.Visible = True
'~~> Sample File
FlName = "C:\Users\routs\Desktop\Sample.Docm"
Set oWordDoc = oWordApp.Documents.Open(FlName)
'~~> Search Text. Change as applicable
SearchText = "Siddharth"
'~~> Move to the begining of the document
oWordDoc.Bookmarks("\StartOfDoc").Select
oWordApp.Selection.Find.ClearFormatting
With oWordApp.Selection.Find
.Text = SearchText
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
'~~> Loop and find the search text
Do While oWordApp.Selection.Find.Execute = True
'~~> Get the page number
pgNo = oWordApp.Selection.Information(wdActiveEndPageNumber)
'~~> Check if the page number is >= 5
If pgNo >= 5 Then
Debug.Print "Search text found in page " & pgNo
End If
Loop
End With
oWordDoc.Close (False)
If IopenedWord = True Then oWordApp.Quit
End Sub
Output
And if I change
If pgNo >= 5 Then
Debug.Print "Search text found in page " & pgNo
End If
to
Debug.Print "Search text found in page " & pgNo
Then I get this
Related
I have created a code that searches different words in a column in a word document.
After finding the word, the code returns the value "yes" to the excel.
I want the code to extract the rest of the sentence after finding the word that I´m looking for.
The rest of the sentences are always something like:
Update system format.
Search for other inputs.
Havent found the sentence that it needs to do.
In conclusion, they are always a small sentence and a new paragraph after.
The code that I have developed is the following:
Sub findSubprocesos()
Dim wrdApp As New Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")
Dim FindWord As String
Dim List As String
Dim Dict As Object
Dim NextFormula As Range
Dim RefElem As Range
Dim Key
Dim Wbk As Workbook: Set Wbk = ThisWorkbook
Set Dict = CreateObject("Scripting.Dictionary")
Set NextFormula = Worksheets("Datos2").Range("V2:V5")
With Dict
For Each RefElem In NextFormula
If Not .Exists(RefElem) And Not IsEmpty(RefElem) Then
Sheets("Datos2").Range("R3").Value = RefElem.Value
Debug.Print RefElem
FindSubs
On Error GoTo Skip
End If
Next RefElem
Skip:
End With
End Sub
Private Sub FindSubs()
Dim wrdApp As New Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")
Dim FindWord As String
Dim List As String
Dim Dict As Object
Dim NextFormula As Range
Dim RefElem As Range
Dim Key
Dim Wbk As Workbook: Set Wbk = ThisWorkbook
Range("U3:U50").ClearContents
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open("C:\Users\rriveragarrido\Desktop\Proyectos\Proyecto solaris (endesa) (PROPIO)\prueba macros\ZZZ\Narrativas antiguas\1059\1059_NAR_OTC.RC.03.01_CC.END.GEN_ENG_31.12.20.docx", OpenAndRepair:=True)
Dim cell As Range
Dim bIsEmpty As Boolean
bIsEmpty = False
For n = 3 To 20
For Each cell In Worksheets("Datos").Range("S" & n)
If IsEmpty(cell) = False Then
FindWord = Wbk.Sheets("Datos2").Range("S" & n).Value 'Modify as necessary.
wrdApp.Selection.WholeStory
wrdApp.Selection.FIND.ClearFormatting
With wrdApp.Selection.FIND
.ClearFormatting
.Text = FindWord
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
If .Execute Then
Sheets("Datos2").Range("U" & n).Value = "Yes"
Else
'Sheets("Datos2").Range("T" & n).Value = "No"
wrdApp.Quit SaveChanges:=0
Sheets("Datos2").Range("U3:U50").Copy Sheets("Subprocesos").Range("A3:A50").End(xlToRight).Offset(0, 1)
GoTo Skip2
End If
End With
End If
Next cell
Next
Skip2:
End Sub
This is the part were I need to extract the rest of the sentence:
If .Execute Then
Sheets("Datos2").Range("U" & n).Value = "Yes"
Else
'Sheets("Datos2").Range("T" & n).Value = "No"
wrdApp.Quit SaveChanges:=0
Sheets("Datos2").Range("U3:U50").Copy Sheets("Subprocesos").Range("A3:A50").End(xlToRight).Offset(0, 1)
Currently is only writing "yes" when the sentence is found and pasting the information in a column and going to the next word if it is not found.
What you want to do is possible by using the Sentences collection of the document. Hopefully you can adapt the sample code below to your needs:
Option Explicit
Sub test()
Dim foundSentences As Collection
Set foundSentences = FindTheSentencesContaining(ThisWord:="access", _
FromThisDoc:="C:\Temp\test.docx")
If foundSentences Is Nothing Then
Debug.Print "The word doc was not found!"
Else
Debug.Print "found " & foundSentences.Count & " sentences"
Dim sentence As Variant
For Each sentence In foundSentences
Debug.Print sentence
Next sentence
End If
End Sub
Function FindTheSentencesContaining(ByVal ThisWord As String, _
ByVal FromThisDoc As String) As Collection
Dim wordWasRunning As Boolean
wordWasRunning = IsMSWordRunning
Dim wordApp As Word.Application
Set wordApp = AttachToMSWordApplication
On Error Resume Next
Dim wordDoc As Word.Document
Set wordDoc = wordApp.Documents.Open(Filename:=FromThisDoc, ReadOnly:=True)
On Error GoTo 0
If wordDoc Is Nothing Then Exit Function
Dim allSentences As Collection
Set allSentences = New Collection
Dim sentence As Variant
For Each sentence In wordDoc.Sentences
sentence.Select
With wordApp.Selection
.Find.Text = ThisWord
.Find.Forward = True
.Find.Wrap = wdFindStop
.Find.MatchCase = False
If .Find.Execute Then
'--- extend the selection to include the whole sentence
.Expand Unit:=wdSentence
allSentences.Add wordApp.Selection.Text
'--- move the cursor to the end of the sentence to continue looking
.Collapse Direction:=wdCollapseEnd
.MoveEnd Unit:=wdSentence
Else
'--- didn't find it, move to the next sentence
End If
End With
Next sentence
wordDoc.Close SaveChanges:=False
If Not wordWasRunning Then
wordApp.Quit
End If
Set FindTheSentencesContaining = allSentences
End Function
In a separate module, I have the following code (pulled from my library of code to reuse):
Option Explicit
Public Function IsMSWordRunning() As Boolean
'--- quick check to see if an instance of MS Word is running
Dim msApp As Object
On Error Resume Next
Set msApp = GetObject(, "Word.Application")
If Err > 0 Then
'--- not running
IsMSWordRunning = False
Else
'--- running
IsMSWordRunning = True
End If
End Function
Public Function AttachToMSWordApplication() As Word.Application
'--- finds an existing and running instance of MS Word, or starts
' the application if one is not already running
Dim msApp As Word.Application
On Error Resume Next
Set msApp = GetObject(, "Word.Application")
If Err > 0 Then
'--- we have to start one
' an exception will be raised if the application is not installed
Set msApp = CreateObject("Word.Application")
End If
Set AttachToMSWordApplication = msApp
End Function
A simple demo outputting the content to a message box, for all found instances:
Sub Demo()
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = InputBox("What is the Text to Find")
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Do While .Find.Execute
With .Duplicate
.End = .Sentences.First.End
MsgBox .Text
End With
.Collapse wdCollapseEnd
Loop
End With
End Sub
Do be aware, though, that VBA has no idea what a grammatical sentence is. For example, consider the following:
Mr. Smith spent $1,234.56 at Dr. John's Grocery Store, to buy:
10.25kg of potatoes; 10kg of avocados; and 15.1kg of Mrs. Green's Mt. Pleasant macadamia nuts.
For you and me, that would count as one sentence; for VBA it counts as 5 sentences.
First of all this is the first time I am creating a macro using VBA code. With some bits and pieces i found on the internet I tried to create the following. I am not a developer at all, I just have some basic knowledge from school. So my apologies if this is poor coding.
I am creating a macro in word which highlights text from a paragraph heading until the next heading with the same style. This is done based on a list of headings I import from Excel. You can find the code I have created below. The result with few input is perfect, so that's a good thing! The execution is very slow though (3 to 4h), which is probably related to the many selects I use. (I read only this is very often the cause of slow macros)
I tried to expand my Range with one line at the time using " Range.Expand Unit:=wdLine " but it's giving me errors every time. Therefore I use the moveDown selection method now which is doing the trick. Does anyone know a way I could use ranges here to speed up the process?
Many thanks in advance.
Sub Highlight_WordN()
Dim par As Paragraph
Dim par2 As Paragraph
Dim doc As Document
Dim oRng As Range
Dim Sty As Style
Dim intCurrentLine As Integer
Dim strFindArray() As String
Dim strIn As String
Dim strWorkBookName As String
Dim strNumberCells As String
Dim MessageFound As String
Dim MessageNotFound As String
Dim Flag As Boolean
Dim IsHeading As Boolean
Dim IsNothing As Boolean
'*****Set parameters for performance*****
Word.Application.ScreenUpdating = False
Word.Application.Options.CheckGrammarAsYouType = False
Word.Application.Options.CheckGrammarWithSpelling = False
Word.Application.Options.CheckSpellingAsYouType = False
Word.Application.Options.AnimateScreenMovements = False
Word.Application.Options.BackgroundSave = False
Word.Application.Options.CheckHangulEndings = False
Word.Application.Options.DisableFeaturesbyDefault = True
'*****Load data from excel*****
'List of headers to delete
Dim xlApp As Object
Dim xlBook As Object
strWorkBookName = "C:\Users\driesenn\OneDrive\OMAR\UPDATE\ToDelete.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err Then
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Set xlBook = xlApp.Workbooks.Open(FileName:=strWorkBookName)
xlApp.Visible = False
ArrayLen = 0
ArrayLen = xlApp.ActiveSheet.Range("B1")
strNumberCells = "A1:A" & ArrayLen
strArray = xlApp.Transpose(xlApp.ActiveSheet.Range(strNumberCells))
ArrayLen = 0
ArrayLen = UBound(strArray) - LBound(strArray) + 1
Set xlBook = Nothing
xlApp.Quit
Set xlApp = Nothing
'*****Start evaluation process for headers*****
ArrayLen = UBound(strArray) - LBound(strArray) + 1
'Loop over all headers in the array
For i = 1 To ArrayLen
strFind = strArray(i)
'Evaluate every paragraph heading
For Each par In ActiveDocument.Paragraphs
If par.Style Like "Heading*" Then
Set Sty = par.Style
'Search for the header number in the heading
If InStr(par.Range.Text, strFind) = 1 Then
Set oRng = par.Range
oRng.Select
intCurrentLine = oRng.Information(wdFirstCharacterLineNumber)
Set oRng = Selection.Next(Unit:=wdLine, Count:=1)
'If the next line is not a header --> go on
IsHeading = False
If oRng.Style Like "Heading*" Then
IsHeading = True
End If
'Keep looping until the next heading of this type is found
Do While oRng.Style > Sty Or IsHeading = False
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
Set oRng = Selection.Next(Unit:=wdLine, Count:=1)
If oRng Is Nothing Then
Exit Do
End If
'If the next line is not a header --> go on
IsHeading = False
If oRng.Style Like "Heading*" Then
IsHeading = True
End If
Loop
Selection.Start = par.Range.Start
'If we are not at the end of the document selection ends with last line of current range.
If oRng Is Nothing Then
Else
Selection.End = oRng.Start
End If
'Set highlight
Selection.Range.HighlightColorIndex = wdYellow
End If
End If
Next
Next
End Sub
Firstly, it will assist you to become familiar with using help. Place your cursor in the keyword that you need help with and press F1. Had you done so for the Expand method you would have landed here. You will find the valid parameters for Unit are listed.
Secondly, paragraph styles are applied to paragraphs not lines. So you need to check the style of each paragraph and expand the range by one paragraph at a time. This will enable you to avoid selecting anything.
The following code shows a much easier way of highlighting the ranges associated with different heading levels, using Word's built-in '\HeadingLevel' bookmark:
Sub Demo()
Dim h As Long, c As Long, Rng As Range
For h = 1 To 9
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Style = "Heading " & h
.Replacement.Text = ""
.Format = True
.Forward = True
.Execute
End With
Do While .Find.Found
Set Rng = .Paragraphs(1).Range
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
Select Case h
Case 1 To 4: c = h + 1
Case 5: c = h + 2
Case 6 To 8: c = h + 4
Case 9: c = h + 5
Case Else: c = 0
End Select
Rng.HighlightColorIndex = c
.Collapse wdCollapseEnd
If .Information(wdWithInTable) = True Then
If .End = .Cells(1).Range.End - 1 Then
.End = .Cells(1).Range.End
.Collapse wdCollapseEnd
If .Information(wdAtEndOfRowMarker) = True Then .End = .End + 1
End If
End If
If .End = ActiveDocument.Range.End Then Exit Do
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Next
End Sub
Of course, as the above code loops through all 9 heading levels, what ends up with a given highlight depends on how many other lower-level headings (higher numbers) are nested within a given higher-level heading (lower numbers).
I am writing a VBA code to enter a user form and then transfer that data from the Excel sheet to an already existing Word document.
My Excel part is ok.
My document contains various words like Batch No, Manufacturing date, etc. each many times. I will have to find these words and insert Batch No and Manufacturing date from the user form every time they are found in the whole document.
Initially, I tried to find a single word in the whole document, but my sub routine can find only the first instance and is not finding similar words in rest of the document.
Please help
Sub Copy_data2()
Dim my_filename As Variant
Dim my_filenameword As Variant
Dim objselection As Object
'Word Variables
Dim mres As String
Dim oword As Object
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim bfound As Boolean
Dim rngDoc As Word.Range
Dim rngSearch As Word.Range
'Excel Variables
Dim wkbk As Workbook
Dim irow As Long
Dim txtSl As String
Dim txtBNo As String
Dim txtPr As String
Dim txtBS As String
Dim txtMfD As String
Dim txtExD As String
Dim workinglocation As String
Dim workingfilename As String
Dim workingdir As String
Dim ret As Boolean
Dim VbRes As String
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
'--------------------------------------------------------------------------------------------
'Excel extract values
'------------------------------------------------------------------------------------------
VbRes = MsgBox("Please select the Requisition sheet", vbOKOnly + vbInformation, "Select the requisition file")
my_filename = Application.GetOpenFilename(FileFilter:="Excel Files,*.xls*")
Set wkbk = Workbooks.Open(my_filename)
txtPr = FrmMaster.CmbProduct.Text
txtBNo = FrmMaster.txtBatchNo
txtBS = FrmMaster.txtBatchSize
txtMfD = FrmMaster.txtMfgDate
txtExD = FrmMaster.txtExpDate
wkbk.Sheets("Requisition").Range("C9") = txtBNo
wkbk.Sheets("Requisition").Range("G9") = txtBS
wkbk.Sheets("Requisition").Range("C10") = txtMfD
wkbk.Sheets("Requisition").Range("G10") = txtExD
irow = [Counta(Database!A:A)]
ThisWorkbook.Sheets("Database").Cells(irow, 1) = txtSl
Debug.Print txtSl
'-------------------------------------------------------------------------------------------------
'VB Word
'----------------------------------------------------------------------------------------------
mres = MsgBox("Select the Word BMR", vbOKOnly + vbInformation, "Select BMR")
my_filenameword = Application.GetOpenFilename(FileFilter:="Word Files,*.doc*")
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
wdApp.Activate
Set wdDoc = wdApp.Documents.Open(my_filenameword)
wdDoc.Activate
With wdApp.Selection.Range.Find
.ClearFormatting
.Text = "BATCH SIZE"
bfound = .Execute(Forward:=True)
Do While bfound = True
'.Move Unit:=wdCharacter, Count:=4
.Text = "BATCH SIZE"
.Replacement.Text = "Size"
Loop
End With
my_filenameword.Close True
wkbk.Close True
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
You really should spend a few moments studying Find/Replace in Word. Even the macro recorder there would give you most of the code you need. Try:
Set wdDoc = wdApp.Documents.Open(my_filenameword, , False, False, , , , , , , , False)
With wdDoc
With .Range.Find
.Forward = True
.Wrap = wdFindContinue
.Text = "BATCH SIZE"
.Replacement.Text = "Size"
.Execute Replace:=wdReplaceAll
End With
.Close True
End With
As you can see, no looping is required - just a proper application of Find/Replace.
'Im catching keywords (string) from an excel file and searching for them in a word doc. When found the string in the doc file is replaced with a specific content from an offset cell.This works for me .Some of the cells have multiple texts separated with semicolon ";".Each text must replace an occurrence of the found keyword in the doc file: for example if a cell contains 3 strings separated with a semicolon ,the first string should replace the first occurrence of the keyword in the doc file,the second one the second occurrence and the third one the third occurrence. I couldn't get a correct result. Below is the code:
Option Explicit
Public Sub copy_file(source, destination)
Dim FsyObjekt As Object
Set FsyObjekt = CreateObject("Scripting.FileSystemObject")
FsyObjekt.CopyFile source, destination
End Sub
Public Sub WordFindAndReplace(Index_offset, ProdType)
Dim ws As Worksheet, msWord As Object, itm As Range
Dim spl() As String, NbLines, Index, Occurences As Integer
Set ws = ActiveSheet
Set msWord = CreateObject("Word.Application")
Index = 0
With msWord
.Visible = True
.Documents.Open Filename:=ThisWorkbook.Path & "\Template.docx"
.Activate
With .ActiveDocument.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
For Each itm In ws.Range("A6:A221")
.Text = itm.Text
If IsEmpty(itm.Offset(, Index_offset)) Then
.Replacement.Text = " "
Else
If InStr(1, itm.Offset(, Index_offset), ";", 1) > 0 Then
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Execute Replace:=wdReplaceOne
spl = Split((itm.Offset(, Index_offset)), ";")
NbLines = UBound(spl) - LBound(spl) + 1
Index = 0
If Index <> NbLines - 1 Then
.Replacement.Text = spl(Index)
Index = Index + 1
End If
Else
.Replacement.Text = itm.Offset(, Index_offset).Text
.Execute Replace:=wdReplaceAll
End If
End If
.MatchCase = False
.MatchWholeWord = False
.Replacement.Highlight = False
Next itm
End With
.Quit SaveChanges:=True
End With
End Sub
I hope someone could help me to solve the problem.
The parameter you pass in 'ProdType' isn't used in the code you have published.
I've updated the code you published and it compiles, but obviously I can't run it because I don't have your worksheet and documents.
But it will help point you in the right direction
A key thing to note is how the search and replace operations have been split out from your main loop. This make the code much easier to follow.
Good luck with your endeavors.
Public Sub WordFindAndReplace(Index_Offset As Long, ProdType As String) ' ProdType is not used in the code you published
Const blankString As String = " " ' might bebetter using vbnullstring instead of " "
Dim ws As Excel.Worksheet ' Requires that Tools.References.Microsoft Excel X.XX Object Library is ticked
Dim msWord As Word.Application ' Requires that Tools.References.Microsoft Word X.XX Object Library is ticked
Dim spl() As String ' changed back to string as we can also iterate over a string array
Dim mySpl As Variant ' the variable in a for each has to be an object or variant
Dim myIndex As Long ' Was implicitly declared as Variant
Dim myDoc As Word.Document ' Better to get a specific reference to a document rather than use activedocument
Dim myOffsetString As String
Dim myFindString As String '
Dim myCells() As Variant
Dim myOffsetCells As Variant
Dim myOffsetRange As Variant
Set ws = ActiveSheet
Set msWord = New Word.Application ' changed from late to early binding as early binding gives intelisense for word objects
'Index = 0 not needed any more
With msWord
.Visible = True ' Not necessary if you just want to process some actions on a document but helpful when developing
Set myDoc = .Documents.Open(FileName:=ThisWorkbook.Path & "\Template.docx") 'changed to function form due to assignment to myDoc
'.Activate ' Not needed when working with a direct reference to a document
End With
' Bring the cells in the target column and the offset column into vba arrays
' an idiosyncracy when pullin in a column is we get a two dimensional array
myCells = ws.Range("A6:A221").Value2
myOffsetRange = Replace("A6:A221", "A", Chr$(Asc("A") + Index_Offset))
myOffsetCells = ws.Range(myOffsetRange).Value2
' As we are using two arrays we can't now do for each so back to using an index
' Another idiosyncracy is that the arrays start at 1 and not 0
For myIndex = 1 To UBound(myCells)
myOffsetString = CStr(myOffsetCells(myIndex, 1))
myFindString = CStr(myCells(myIndex, 1))
If Len(myOffsetString) = 0 Then 'quicker than comparing against vbnullstring
replaceText_ReplaceAll myDoc, myFindString, blankString
Else
' The offset cell contains a string (because it is not empty)
' It doesn't matter if there is no ';' in the string
' split will just produce an array with one cell
spl = Split(myOffsetString, ";")
If UBound(spl) = 0 Then
' Only one item present
replaceText_ReplaceAll myDoc, myFindString, Trim(CStr(mySpl))
Else
' more than one item present
For Each mySpl In spl
replaceText_ReplaceSingleInstance myDoc, myFindString, Trim(CStr(mySpl))
Next
' now replace any excess ocurrences of myFIndString
replaceText_ReplaceAll myDoc, myFindString, blankString
End If
End If
Next
myDoc.Close savechanges:=True
msWord.Quit
Set msWord = Nothing
End Sub
Sub replaceText_ReplaceAll(this_document As Word.Document, findText As String, replaceText As String)
With this_document.StoryRanges(wdMainTextStory).Find
.ClearFormatting
.Format = False
.Wrap = wdFindStop
.Text = findText
.Replacement.Text = replaceText
.Forward = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
End Sub
Sub replaceText_ReplaceSingleInstance(this_document As Word.Document, findText As String, replaceText As String)
With this_document.StoryRanges(wdMainTextStory).Find
.ClearFormatting
.Format = False
.Wrap = wdFindContinue
.Text = findText
.Replacement.Text = replaceText
.Forward = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
End Sub
Edited to update the WordFIndAndReplace sub
I have an excel sheet with two columns of strings. I track the changes of these two columns using ms-word and copy the result back to a third column. Then I copy the third column to a new word document.
The formating in Excel in Cell C3 is what I would like to transfer to word.
This is what I get at the moment. Notice the complete strike-through.
Why does it work twice but not in the third case?
I guess the root of the problem is that I remove the CR/Linefeed in the word to excel step and destroy the boundary of the strike-through-format. My goal is to get each string in one word-paragraph. If I don't remove the CR/Linefeed i get four paragraphs.
Background: In the final application the strings are going to be paragraphs of text.
Sourcecode of the excel-vba-macro (Excel 2010):
Technical remark: You may need to activate the ms-word-objects in excel-vba. (Microsoft Word 14.0 Object Library )
The macro assumes, that there a strings in the Range(A1:B3):
for example
a string a string, too
a string a new string
a string there is no try
The results will be put in the Range(C1:C3).
Option Explicit
Dim numberOfBlocks As Long
Sub main()
Dim i As Long
Dim tSht As Worksheet
Dim wordapp As Word.Application
Dim wdoc As Word.Document
Set tSht = ThisWorkbook.ActiveSheet
numberOfBlocks = 3
Application.ScreenUpdating = False
Set wordapp = CreateObject("Word.Application")
For i = 1 To numberOfBlocks
Call trackChanges(i, wordapp, tSht)
Next i
Set wdoc = wordapp.Documents.Add
Call copyChanges(tSht, wdoc)
End Sub
Sub trackChanges(i As Long, wordapp As Word.Application, tSht As Worksheet)
Dim diffDoc As Word.Document
Dim textString() As Variant
Dim j As Long
ReDim doc(2)
ReDim textString(2)
Set textString(1) = tSht.Range("A" & i)
Set textString(2) = tSht.Range("B" & i)
For j = 1 To 2
With wordapp
Set doc(j) = .Documents.Add
textString(j).Copy
doc(j).Paragraphs(1).Range.PasteSpecial
End With
Next j
wordapp.CompareDocuments OriginalDocument:=doc(1), RevisedDocument:=doc(2), _
Destination:=wdCompareDestinationNew, Granularity:=wdGranularityCharLevel
For j = 1 To 2
doc(j).Close SaveChanges:=False
Next j
Set diffDoc = wordapp.ActiveDocument
wordapp.Visible = True
'if the answer has two paragraphs, get both in one paragraph
With diffDoc.Content.Find
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
.Text = vbCrLf
.Replacement.Text = " "
.Execute Replace:=wdReplaceAll
End With
diffDoc.Range.Copy
tSht.Range("C" & i).Select
tSht.PasteSpecial Format:="HTML"
With tSht.Range("C" & i)
.WrapText = True
.Font.Name = textString(2).Font.Name
.Font.Bold = textString(2).Font.Bold
.Font.Size = textString(2).Font.Size
.Rows.AutoFit
.Interior.Color = textString(2).Interior.Color
End With
diffDoc.Close SaveChanges:=False
Application.CutCopyMode = False
Set diffDoc = Nothing
End Sub
Sub copyChanges(tSht As Worksheet, wdoc As Word.Document)
tSht.Range("C1:C" & numberOfBlocks).Copy
wdoc.Range(wdoc.Range.End - 1, wdoc.Range.End).PasteSpecial Placement:=wdInLine, DataType:=wdPasteHTML
wdoc.Tables(1).ConvertToText Separator:=wdSeparateByParagraphs
End Sub