Page 4 of 4 FirstFirst ... 234
Results 31 to 36 of 36

Thread: 40$ Word Macro Highlight Keywords And Maps Checklisted Words In A Listbox

  1. #31
    Member littleiitin's Avatar
    Join Date
    Aug 2011
    Posts
    90
    Rep Power
    13
    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

  2. #32
    Junior Member
    Join Date
    Jul 2012
    Posts
    18
    Rep Power
    0
    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

  3. #33
    Junior Member
    Join Date
    Jul 2012
    Posts
    18
    Rep Power
    0
    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 !
    Last edited by Sri; 07-27-2012 at 12:50 PM.

  4. #34
    Member littleiitin's Avatar
    Join Date
    Aug 2011
    Posts
    90
    Rep Power
    13
    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
    Last edited by littleiitin; 07-27-2012 at 08:27 PM.

  5. #35
    Member littleiitin's Avatar
    Join Date
    Aug 2011
    Posts
    90
    Rep Power
    13
    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

  6. #36
    Member littleiitin's Avatar
    Join Date
    Aug 2011
    Posts
    90
    Rep Power
    13
    Thanks Sri,

    Received money..


    Thanks
    Rahul Kumar Singh

Similar Threads

  1. Replies: 7
    Last Post: 08-24-2015, 10:58 PM
  2. Highlight Active Cell’s Row and Column
    By Transformer in forum Tips, Tricks & Downloads (No Questions)
    Replies: 0
    Last Post: 05-17-2013, 12:32 AM
  3. Replies: 1
    Last Post: 10-16-2012, 01:53 PM
  4. Replies: 4
    Last Post: 08-14-2012, 03:17 AM
  5. Replies: 7
    Last Post: 06-23-2012, 07:56 PM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •