-
Sri Please find The code for Moving from One Keyword to other: I have assigned a Hot Key Crtl+6
Just Add a module and place this code:
Code:
Sub CheckMove()
Dim lngStart As Long
Do
lngStart = Selection.Start
Selection.Move unit:=wdWord
Selection.MoveRight unit:=wdWord, Extend:=wdExtend
If Selection.Bookmarks.Exists("\EndOfDoc") = True Then
Selection.GoTo what:=wdGoToLine, which:=wdGoToFirst, Count:=1, Name:=""
End If
If Selection.Font.Color = wdColorGreen And Selection.Range.HighlightColorIndex = wdYellow Then
Exit Sub
End If
Loop
End Sub
Regarding the error: either your file is readonly or you don't have write permission.
Or some time it get locked.. So I have suggestion Just Move your Text In the file where code is running fine...
Thanks
Rahul Kumar Singh
-
Hello Rahul,
The macro seems to work fine when its in compatibility mode taht si when i save it as a word 97-2003 document.But then I use word 2010 so the code fails to run in that case and i get runtime error 4605 format issues. I have some process controls in the document so i have to maintain the docx format. So i am in a fix as to what i should do.
I see that you have posted a function to move from one keyword to the other, But what can i do about unwanted searches like if the keyword is DA and RA the search highlights unwanted results like a"da"pation and t"ra"nsmission. Can you please fix this. My previous post i have explained this problem more clearly. Please look into it
Regards,
Sri
-
The problem is that i have some process controls for date document version etc in my word document which is a docx file and hence when i execute i get the error. What can be done so that it works on docx files too without the runtime error. Please let me know if there a way out. ANd also kindly look into the unwante keywords being a part of the string also being highlighted. Like DA keyword a"da"ptation gets highlighted which is unnecessary. Probably you can check for space after keyword that.way keywords which occur as a part of the word can get eliminated. Thanks a ton !
-
Sri Save File as Macro enabled file.. Its Extension is .docm and docx
In previous file I have provided solution to highlight only complete word and not part of the word.
Please Use Below Code iN place of Previous One:
Code:
Sub CheckMove()
Dim lngStart As Long
Dim lngCntFlag As Long
Application.ScreenUpdating = False
Do
If lngCntFlag <> 2 Then
lngStart = Selection.Start
Selection.Move unit:=wdWord
Selection.MoveRight unit:=wdWord, Extend:=wdExtend
If Selection.Bookmarks.Exists("\EndOfDoc") = True Then
lngCntFlag = lngCntFlag + 1
Selection.GoTo what:=wdGoToLine, which:=wdGoToFirst, Count:=1, Name:=""
End If
If Selection.Font.Color = wdColorGreen And Selection.Range.HighlightColorIndex = wdYellow Then
Exit Sub
End If
Else
Selection.GoTo what:=wdGoToLine, which:=wdGoToFirst, Count:=1, Name:=""
MsgBox "There is no highlighted Keyword in file."
Exit Sub
End If
Loop
Application.ScreenUpdating = True
End Sub
Thanks
Rahul Kumar singh
-
Please Replace This Code:
Code:
Sub SelectAllKeywords()
Dim objExcel As Object
Dim wbkExcel As Object
Dim wksAct As Object
Dim wksCheck As Object
Dim rngWhole As Object
Dim rngCell As Object
Dim strSearch As String
Dim rngRange As Range
Dim lngRow As Long
Dim lngcol As Long
Dim lngRowN As Long
Dim lngcolN As Long
Dim lngTableCre As Double
Dim lngTableFlag As Long
Dim strFilePath As String
Dim rngCheck As Object
Dim rngKey As Object
Dim wksNew As Object
Dim rngFin As Object
Dim lngCntr As Long
Dim tblTable As Table
Dim lngTblID As Long
Application.ScreenUpdating = False
For Each tblTable In ActiveDocument.Tables
lngTblID = lngTblID + 1
tblTable.ID = lngTblID
Next
Set objExcel = CreateObject("Excel.Application")
strFilePath = FilePicker
If strFilePath = "" Then
GoTo Xit
End If
objExcel.Visible = True
Set wbkExcel = objExcel.workbooks.Open(strFilePath)
Set wksAct = wbkExcel.worksheets("KeyWord")
Set wksCheck = wbkExcel.worksheets("Checklist")
With wksAct
Set rngKey = wksAct.Application.Intersect(.UsedRange, .UsedRange.Offset(1))
varKeywords = rngKey
Set rngWhole = rngKey.Columns(rngKey.Columns.Count)
End With
With wksCheck
Set rngCheck = wksCheck.Application.Intersect(.UsedRange, .UsedRange.Offset(1))
varCheck = rngCheck
End With
wbkExcel.Sheets.Add After:=wbkExcel.Sheets(wbkExcel.Sheets.Count)
Set wksNew = wbkExcel.activesheet
With wksNew
rngCheck.Copy .Range("A2")
' .Range("A2").PasteSpecial xlpasteall
.Range("C2").Value = "=Vlookup(A2," & rngKey.Address(, , , 1) & ",2)"
.Range("D2").Value = "=B2"
Set rngFin = .Range("C2:D" & rngCheck.Rows.Count + 1)
rngFin.filldown
With ThisDocument.ListBox11
.Clear
.ColumnCount = 2
For lngCntr = 1 To rngFin.Rows.Count - 1
.AddItem rngFin.Columns(1).Cells(lngCntr)
.List(lngCntr - 1, 1) = CStr(rngFin.Columns(2).Cells(lngCntr).Value)
Next
End With
End With
ThisDocument.ListBox11.Height = 1
ThisDocument.ListBox11.Width = 1
Set rngRange = ActiveDocument.Range
Selection.GoTo what:=wdGoToLine, which:=wdGoToFirst, Count:=1, Name:=""
ThisDocument.ListBox1.Clear
ThisDocument.ListBox12.Clear
For Each rngCell In rngWhole.Cells
ThisDocument.ListBox1.AddItem rngCell.Value
Do
Selection.Find.ClearFormatting
Selection.Find.Text = rngCell.Value
Selection.Find.MatchWholeWord = True
strSearch = rngCell.Value
Selection.Find.MatchWholeWord = True
Selection.Find.Execute
If Selection.Information(wdWithInTable) = True Then
If Selection.Tables(1).ID <> lngTableCre Or (Selection.Tables.Parent.Cells(1).ColumnIndex <> lngcol Or Selection.Tables.Parent.Cells(1).RowIndex <> lngRow) Then
lngTableFlag = 0
lngcol = 0
lngRow = 0
lngTableCre = 0
End If
End If
If lngcol = 0 And lngRow = 0 And lngTableCre = 0 Then
Selection.Font.Color = wdColorGreen
Selection.Range.HighlightColorIndex = wdYellow
End If
If Selection.Information(wdWithInTable) = True Then
If Selection.Tables(1).ID <> lngTableCre Or (Selection.Tables.Parent.Cells(1).ColumnIndex <> lngcol Or Selection.Tables.Parent.Cells(1).RowIndex <> lngRow) Then
lngcol = Selection.Tables.Parent.Cells(1).ColumnIndex
lngRow = Selection.Tables.Parent.Cells(1).RowIndex
lngTableCre = Selection.Tables(1).ID
lngTableFlag = 1
End If
End If
If Selection.Information(wdWithInTable) = True Then
If Selection.Tables.Parent.Cells(1).ColumnIndex <> lngcol Or Selection.Tables.Parent.Cells(1).RowIndex <> lngRow Then
Selection.Font.Color = wdColorGreen
Selection.Range.HighlightColorIndex = wdYellow
End If
End If
Loop While Selection.Find.Found
Selection.GoTo what:=wdGoToLine, which:=wdGoToFirst, Count:=1, Name:=""
lngTableFlag = 0
lngcol = 0
lngRow = 0
lngTableCre = 0
Next
wbkExcel.Close 0
Set wbkExcel = Nothing
Xit:
objExcel.Quit
Application.ScreenUpdating = True
End Sub
-
Thanks Sri,
Received money..
Thanks
Rahul Kumar Singh
