Re: MS Word Macro for Find & Export to Excel

D

danielbasilio

New Member
Joined
Jan 13, 2017
Messages
5
Re: MS Word Macro for Find & Export to Excel

I have many documents that I need find some text. In all documents cant have "0,00" sentence. So I need a macro to find where is localized the file that contains this text and export it to excel in a list...
Models:

01-DOCUMENTS FILES = http://imagizer.imageshack.us/a/img922/7069/ezmC8j.jpg
02-TEXT TO FIND = http://imagizer.imageshack.us/a/img921/2301/18iWO3.jpg
03-EXCEL FINAL LIST = http://imageshack.com/a/img921/6516/FTYXeu.jpg







I insert this code in yours macro to select many docs to do the same with all documents selected, cause your code just do it for the openned document...
But this dont works well, any one can help me?


Code: 
Dim MyDialog As FileDialog, GetStr(1 To 100) As String '100 files is the maximum applying this code      
On Error Resume Next
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
.Filters.Clear
.Filters.Add "All WORD File ", "*.docx", 1
.AllowMultiSelect = True
i = 1
If .Show = -1 Then
For Each stiSelectedItem In .SelectedItems
GetStr(i) = stiSelectedItem
i = i + 1
Next
i = i - 1
End If
Application.ScreenUpdating = False
For j = 1 To i Step 1
Next
End With
      
      If .Find.Found Then
        Set Doc = Documents.Open(Filename:=GetStr(j), Visible:=True)
Windows(GetStr(j)).Activate


Code: 
Sub GoToAPageAndLine() '' Makro created on 22.01.2013
'
    Dim TargetDocName, SearchTerm, MyString As String, TargetDoc As Document
    Dim PosDelimiter, PosMakroButton, Page, Line
    'Read Private Field which contains The Document Name
    MyString = Mid$(Selection.Fields(2).Code, 10)
    MyString = Left$(MyString, Len(MyString) - 1)
    PosDelimiter = InStr(MyString, "|")
    TargetDocName = Left$(MyString, PosDelimiter - 1)
    SearchTerm = Mid$(MyString, PosDelimiter + 1)
    'MsgBox TargetDocName
    'Read the MakroButton Text which contains Page Number and Line
    MyString = Mid$(Selection.Fields(1).Code, 1)
    PosMakroButton = InStr(MyString, "MACROBUTTON")
    MyString = Mid$(MyString, PosMakroButton + 32)
    PosDelimiter = InStr(MyString, ", ")
    Page = Left$(MyString, PosDelimiter - 1)
    Line = Mid$(MyString, PosDelimiter + 4)
    'MsgBox Page
    'MsgBox Line
    On Error GoTo Errhandler
    Set TargetDoc = Documents(TargetDocName)
    TargetDoc.Activate
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=Page, Name:=""
    If Line - 1 > 0 Then
        Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative, Count:=Line - 1, Name:=""
    End If
    If SearchTerm <> "" Then
        Selection.Find.ClearFormatting
        With Selection.Find
            .Text = SearchTerm
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        Selection.Find.Execute
    End If
Errhandler:
    Select Case Err
        Case 4160: 'Error 4160 = Bad file name
            MsgBox "The file """ & TargetDocName & """ isn't open. Please open the file first."
    End Select
End Sub
Sub macrobutton(Page, Line As Integer, Filename, SearchTerm As String)
'
' Makro created on 22.01.2013
'
    Dim oField As Field, MyRange As Range
    Set MyRange = Selection.Range
    Set oField = Selection.Fields.Add(Range:=MyRange, Type:=wdFieldEmpty, Text:= _
        "MACROBUTTON GoToAPageAndLine S. " & Page & ", Z. " & Line & "", PreserveFormatting:= _
        False)
    Set oRange = ActiveDocument.Range(oField.Code.Start + 1, oField.Code.Start + 1)
    ActiveDocument.Fields.Add Range:=oRange, Type:=wdFieldPrivate, Text:="" & Filename & "|" & SearchTerm, PreserveFormatting:=False
End Sub
Sub CopyHighlightedTextInNewDocument()
'
' Makro created on 22.01.2013
'
    ActiveDocument.Range(0, 0).Select
    With Selection
        .Find.ClearFormatting
        .Find.Highlight = True
        With .Find
            .Replacement.ClearFormatting
            .Text = ""
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        Set CurrentDoc = ActiveDocument
        Set NewDoc = Documents.Add(Visible:=True)
        NewDoc.Content.InsertAfter "Summary of the highlighted text in " & """" & CurrentDoc.Name & """"
        NewDoc.Content.Font.Bold = True
        NewDoc.Content.InsertParagraphAfter
        NewDoc.Content.InsertParagraphAfter
        .Find.Execute
        Dim PageNumber, LineNumber As Integer
        Do While .Find.Found
            .Select
            Selection.Copy
            PageNumber = .Information(wdActiveEndPageNumber)
            LineNumber = .Information(wdFirstCharacterLineNumber)
            NewDoc.Activate
            With Selection
              .EndKey Unit:=wdStory
              .Font.Bold = True
              .Font.Underline = True
              .Font.ColorIndex = wdDarkBlue
              Call macrobutton(PageNumber, LineNumber, CurrentDoc.Name, "")
              .Font.Bold = True
              .Font.Underline = False
              .Font.ColorIndex = wdBlack
              '.InsertAfter "S. " & PageNumber
              '.InsertAfter ", Z. " & LineNumber
              .TypeText "______________________________________________________________" & vbCr
              .InsertParagraphAfter
              .MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
              .Paste
              .InsertParagraphAfter
              .InsertParagraphAfter
              .MoveDown Unit:=wdLine, Count:=2, Extend:=wdMove
            End With
            CurrentDoc.Activate
            .Find.Execute
        Loop
    End With
    NewDoc.Activate
    Options.ButtonFieldClicks = 1
    Selection.HomeKey Unit:=wdStory
    ActiveWindow.Visible = True
End Sub
Sub CopyKeywordPlusContext()
'
' Makro created on 22.01.2013
'




    
    Dim SearchTerm As String, WordsAfter As Long, WordsBefore As Long, i As Long
    Dim Rng As Range, Doc As Document, RngOut As Range
    SearchTerm = InputBox("Enter your search terms, Maria Cancro!" & vbCr & _
      "Then, sit back, relax, and let this macro do some heavy lifting." & vbCr & _
      vbCr & "It's okay - it works out!")
    SearchTerm = LCase(Trim(SearchTerm))
    If Len(SearchTerm) = 0 Then Exit Sub
    WordsBefore = InputBox("Enter the number of words before your search term to find.")
    WordsAfter = InputBox("Enter the number of words after your search term to find.")
    ActiveDocument.Range(0, 0).Select
    With Selection
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = SearchTerm
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .Execute
      End With
      
      
Dim MyDialog As FileDialog, GetStr(1 To 100) As String '100 files is the maximum applying this code
      
On Error Resume Next
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
.Filters.Clear
.Filters.Add "All WORD File ", "*.docx", 1
.AllowMultiSelect = True
i = 1
If .Show = -1 Then
For Each stiSelectedItem In .SelectedItems
GetStr(i) = stiSelectedItem
i = i + 1
Next
i = i - 1
End If
Application.ScreenUpdating = False
For j = 1 To i Step 1
Next
End With
      
      If .Find.Found Then
        Set Doc = Documents.Open(Filename:=GetStr(j), Visible:=True)
Windows(GetStr(j)).Activate
        Doc.Content.InsertAfter "Search results for """ & SearchTerm & """ + context in " & """" & CurrentDoc.Name & """"
        Doc.Content.Font.Bold = True
        Doc.Content.InsertParagraphAfter
        Doc.Content.InsertParagraphAfter
        Dim CheckAuto As Integer
        CheckAuto = MsgBox("Should all findings be copied automatically ('yes') or do you want to check each occurence manually ('no') ?", vbYesNo, "Automatically oder manually?")
        Dim CopyThis As Boolean
        Do While .Find.Found
          CopyThis = False
          Set Rng = .Range.Duplicate
          With Rng
            .Select
            Dim SelectionStart, SelectionEnd
            SelectionStart = Selection.Range.Start
            SelectionEnd = Selection.Range.End
            ActiveDocument.Range(SelectionStart, SelectionStart).Select
            Dim PageNumber, LineNumber As Integer
            PageNumber = Selection.Information(wdActiveEndPageNumber)
            LineNumber = Selection.Information(wdFirstCharacterLineNumber)
            .MoveStart wdWord, -WordsBefore
            .MoveEnd wdWord, WordsAfter + 2
            .Select
            Selection.MoveStart Unit:=wdLine, Count:=-1 'Comment this out if you
            Selection.MoveEnd Unit:=wdLine, Count:=1    '                        don't want the selection to be extended to the start / end of line
            If CheckAuto = vbYes Then
                CopyThis = True
            Else
                Dim Check As Integer
                Check = MsgBox(.Text, vbYesNoCancel, "Copy this block?")
                If Check = vbCancel Then
                    Exit Do
                ElseIf Check = vbYes Then
                    CopyThis = True
                End If
            End If
            If CopyThis = True Then
              Selection.Copy
              Doc.Activate
              With Selection
                  .EndKey Unit:=wdStory
                  .Font.Bold = True
                  .Font.Underline = True
                  .Font.ColorIndex = wdDarkBlue
                  Call macrobutton(PageNumber, LineNumber, CurrentDoc.Name, SearchTerm)
                  .Font.Bold = True
                  .Font.Underline = False
                  .Font.ColorIndex = wdBlack
                  '.InsertAfter "S. " & PageNumber
                  '.InsertAfter ", Z. " & LineNumber
                  .TypeText "______________________________________________________________" & vbCr
                  .InsertParagraphAfter
                  .MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
                  .Paste
                  .InsertParagraphAfter
                  .InsertParagraphAfter
                  .MoveDown Unit:=wdLine, Count:=2, Extend:=wdMove
              End With
              CurrentDoc.Activate
            End If
          End With
          .Collapse wdCollapseEnd
          .Find.Execute
        Loop
        Doc.Activate
      End If
    End With
    With Doc.Range.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = SearchTerm
      .Replacement.Text = "^&"
      .Replacement.Highlight = True
      .Forward = True
      .Wrap = wdFindStop
      .Format = True
      .MatchCase = False
      .MatchWholeWord = False
      .MatchAllWordForms = False
      .MatchSoundsLike = False
      .MatchWildcards = False
      .Execute Replace:=wdReplaceAll
    End With
    Options.ButtonFieldClicks = 1
    Selection.HomeKey Unit:=wdStory
    ActiveWindow.Visible = True


End Sub
 

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
Sort by date Sort by votes
Re: MS Word Macro for Find & Export to Excel

Try the following macro, which includes a folder browser, so all you need do is select the folder to process.:
Code: 
Sub GenerateRefs()
' Note: A reference to the Microsoft Excel Object Library
' is required, via Tools|References in the VBA Editor.
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document
strDocNm = ActiveDocument.FullName
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Dim xlApp As New Excel.Application, xlWb As Excel.Workbook, xlWs As Excel.Worksheet, r As Long
Set xlWb = xlApp.Workbooks.Add: Set xlWs = xlWb.Worksheets(1)
xlApp.Visible = True
xlWs.Cells(1, 1).Value = "Document Name"
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
    With wdDoc
      With .Range.Find
        .ClearFormatting
        .Text = "0,00"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute
        If .Found = True Then
          r = r + 1: xlWs.Cells(r, 1).Value = strDocNm
        End If
      End With
      .Close SaveChanges:=False
    End With
  End If
  strFile = Dir()
Wend
Set wdDoc = Nothing: Set xlWs = Nothing: Set xlWb = Nothing: Set xlApp = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
I don't see the point in dedicating a column to '0,00', as there is only one possibility for the 'Find' text, so I haven't catered for that.

PS: Please don't resurrect old threads for a new topic; start a new one.
 
Upvote 0
Re: MS Word Macro for Find & Export to Excel

Thanks for answer and sorry for open old tread...
But its doesnt works well, see the image of excel final..

qC7QpM.jpg



Is it possible use this code bellow with yours?
Thanks a Lot!


Code: 
Attribute VB_Name = "Módulo1"Sub GoToAPageAndLine() '
' Makro created on 22.01.2013
'
    Dim TargetDocName, SearchTerm, MyString As String, TargetDoc As Document
    Dim PosDelimiter, PosMakroButton, Page, Line
    'Read Private Field which contains The Document Name
    MyString = Mid$(Selection.Fields(2).Code, 10)
    MyString = Left$(MyString, Len(MyString) - 1)
    PosDelimiter = InStr(MyString, "|")
    TargetDocName = Left$(MyString, PosDelimiter - 1)
    SearchTerm = Mid$(MyString, PosDelimiter + 1)
    'MsgBox TargetDocName
    'Read the MakroButton Text which contains Page Number and Line
    MyString = Mid$(Selection.Fields(1).Code, 1)
    PosMakroButton = InStr(MyString, "MACROBUTTON")
    MyString = Mid$(MyString, PosMakroButton + 32)
    PosDelimiter = InStr(MyString, ", ")
    Page = Left$(MyString, PosDelimiter - 1)
    Line = Mid$(MyString, PosDelimiter + 4)
    'MsgBox Page
    'MsgBox Line
    On Error GoTo Errhandler
    Set TargetDoc = Documents(TargetDocName)
    TargetDoc.Activate
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=Page, Name:=""
    If Line - 1 > 0 Then
        Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative, Count:=Line - 1, Name:=""
    End If
    If SearchTerm <> "" Then
        Selection.Find.ClearFormatting
        With Selection.Find
            .Text = SearchTerm
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        Selection.Find.Execute
    End If
Errhandler:
    Select Case Err
        Case 4160: 'Error 4160 = Bad file name
            MsgBox "The file """ & TargetDocName & """ isn't open. Please open the file first."
    End Select
End Sub
Sub macrobutton(Page, Line As Integer, Filename, SearchTerm As String)
'
' Makro created on 22.01.2013
'
    Dim oField As Field, MyRange As Range
    Set MyRange = Selection.Range
    Set oField = Selection.Fields.Add(Range:=MyRange, Type:=wdFieldEmpty, Text:= _
        "MACROBUTTON GoToAPageAndLine S. " & Page & ", Z. " & Line & "", PreserveFormatting:= _
        False)
    Set oRange = ActiveDocument.Range(oField.Code.Start + 1, oField.Code.Start + 1)
    ActiveDocument.Fields.Add Range:=oRange, Type:=wdFieldPrivate, Text:="" & Filename & "|" & SearchTerm, PreserveFormatting:=False
End Sub
Sub CopyHighlightedTextInNewDocument()
'
' Makro created on 22.01.2013
'
    ActiveDocument.Range(0, 0).Select
    With Selection
        .Find.ClearFormatting
        .Find.Highlight = True
        With .Find
            .Replacement.ClearFormatting
            .Text = ""
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        Set CurrentDoc = ActiveDocument
        Set NewDoc = Documents.Add(Visible:=False)
        NewDoc.Content.InsertAfter "Summary of the highlighted text in " & """" & CurrentDoc.Name & """"
        NewDoc.Content.Font.Bold = True
        NewDoc.Content.InsertParagraphAfter
        NewDoc.Content.InsertParagraphAfter
        .Find.Execute
        Dim PageNumber, LineNumber As Integer
        Do While .Find.Found
            .Select
            Selection.Copy
            PageNumber = .Information(wdActiveEndPageNumber)
            LineNumber = .Information(wdFirstCharacterLineNumber)
            NewDoc.Activate
            With Selection
              .EndKey Unit:=wdStory
              .Font.Bold = True
              .Font.Underline = True
              .Font.ColorIndex = wdDarkBlue
              Call macrobutton(PageNumber, LineNumber, CurrentDoc.Name, "")
              .Font.Bold = True
              .Font.Underline = False
              .Font.ColorIndex = wdBlack
              '.InsertAfter "S. " & PageNumber
              '.InsertAfter ", Z. " & LineNumber
              .TypeText "______________________________________________________________" & vbCr
              .InsertParagraphAfter
              .MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
              .Paste
              .InsertParagraphAfter
              .InsertParagraphAfter
              .MoveDown Unit:=wdLine, Count:=2, Extend:=wdMove
            End With
            CurrentDoc.Activate
            .Find.Execute
        Loop
    End With
    NewDoc.Activate
    Options.ButtonFieldClicks = 1
    Selection.HomeKey Unit:=wdStory
    ActiveWindow.Visible = True
End Sub
Sub CopyKeywordPlusContext()
'
' Makro created on 22.01.2013
'
    Dim SearchTerm As String, WordsAfter As Long, WordsBefore As Long, i As Long
    Dim Rng As Range, Doc As Document, RngOut As Range
    SearchTerm = InputBox("Enter your search terms, Maria Cancro!" & vbCr & _
      "Then, sit back, relax, and let this macro do some heavy lifting." & vbCr & _
      vbCr & "It's okay - it works out!")
    SearchTerm = LCase(Trim(SearchTerm))
    If Len(SearchTerm) = 0 Then Exit Sub
    WordsBefore = InputBox("Enter the number of words before your search term to find.")
    WordsAfter = InputBox("Enter the number of words after your search term to find.")
    ActiveDocument.Range(0, 0).Select
    With Selection
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = SearchTerm
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .Execute
      End With
      If .Find.Found Then
        Set CurrentDoc = ActiveDocument
        Set Doc = Documents.Add(Visible:=False)
        Doc.Content.InsertAfter "Search results for """ & SearchTerm & """ + context in " & """" & CurrentDoc.Name & """"
        Doc.Content.Font.Bold = True
        Doc.Content.InsertParagraphAfter
        Doc.Content.InsertParagraphAfter
        Dim CheckAuto As Integer
        CheckAuto = MsgBox("Should all findings be copied automatically ('yes') or do you want to check each occurence manually ('no') ?", vbYesNo, "Automatically oder manually?")
        Dim CopyThis As Boolean
        Do While .Find.Found
          CopyThis = False
          Set Rng = .Range.Duplicate
          With Rng
            .Select
            Dim SelectionStart, SelectionEnd
            SelectionStart = Selection.Range.Start
            SelectionEnd = Selection.Range.End
            ActiveDocument.Range(SelectionStart, SelectionStart).Select
            Dim PageNumber, LineNumber As Integer
            PageNumber = Selection.Information(wdActiveEndPageNumber)
            LineNumber = Selection.Information(wdFirstCharacterLineNumber)
            .MoveStart wdWord, -WordsBefore
            .MoveEnd wdWord, WordsAfter + 2
            .Select
            Selection.MoveStart Unit:=wdLine, Count:=-1 'Comment this out if you
            Selection.MoveEnd Unit:=wdLine, Count:=1    '                        don't want the selection to be extended to the start / end of line
            If CheckAuto = vbYes Then
                CopyThis = True
            Else
                Dim Check As Integer
                Check = MsgBox(.Text, vbYesNoCancel, "Copy this block?")
                If Check = vbCancel Then
                    Exit Do
                ElseIf Check = vbYes Then
                    CopyThis = True
                End If
            End If
            If CopyThis = True Then
              Selection.Copy
              Doc.Activate
              With Selection
                  .EndKey Unit:=wdStory
                  .Font.Bold = True
                  .Font.Underline = True
                  .Font.ColorIndex = wdDarkBlue
                  Call macrobutton(PageNumber, LineNumber, CurrentDoc.Name, SearchTerm)
                  .Font.Bold = True
                  .Font.Underline = False
                  .Font.ColorIndex = wdBlack
                  '.InsertAfter "S. " & PageNumber
                  '.InsertAfter ", Z. " & LineNumber
                  .TypeText "______________________________________________________________" & vbCr
                  .InsertParagraphAfter
                  .MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
                  .Paste
                  .InsertParagraphAfter
                  .InsertParagraphAfter
                  .MoveDown Unit:=wdLine, Count:=2, Extend:=wdMove
              End With
              CurrentDoc.Activate
            End If
          End With
          .Collapse wdCollapseEnd
          .Find.Execute
        Loop
        Doc.Activate
      End If
    End With
    With Doc.Range.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = SearchTerm
      .Replacement.Text = "^&"
      .Replacement.Highlight = True
      .Forward = True
      .Wrap = wdFindStop
      .Format = True
      .MatchCase = False
      .MatchWholeWord = False
      .MatchAllWordForms = False
      .MatchSoundsLike = False
      .MatchWildcards = False
      .Execute Replace:=wdReplaceAll
    End With
    Options.ButtonFieldClicks = 1
    Selection.HomeKey Unit:=wdStory
    ActiveWindow.Visible = True
End Sub
 
Upvote 0
Re: MS Word Macro for Find & Export to Excel

Oops! Change:
r = r + 1: xlWs.Cells(r, 1).Value = strDocNm
to:
r = r + 1: xlWs.Cells(r, 1).Value = strFile
 
Upvote 0
Re: MS Word Macro for Find & Export to Excel

Just one more favor...
Can you edit this code to choose the sentence in many documents, like you make with previous code?
Thanks a lot again!!!


Code: 
Attribute VB_Name = "Módulo1"
Sub GoToAPageAndLine() '
' Makro created on 22.01.2013
'
    Dim TargetDocName, SearchTerm, MyString As String, TargetDoc As Document
    Dim PosDelimiter, PosMakroButton, Page, Line
    'Read Private Field which contains The Document Name
    MyString = Mid$(Selection.Fields(2).Code, 10)
    MyString = Left$(MyString, Len(MyString) - 1)
    PosDelimiter = InStr(MyString, "|")
    TargetDocName = Left$(MyString, PosDelimiter - 1)
    SearchTerm = Mid$(MyString, PosDelimiter + 1)
    'MsgBox TargetDocName
    'Read the MakroButton Text which contains Page Number and Line
    MyString = Mid$(Selection.Fields(1).Code, 1)
    PosMakroButton = InStr(MyString, "MACROBUTTON")
    MyString = Mid$(MyString, PosMakroButton + 32)
    PosDelimiter = InStr(MyString, ", ")
    Page = Left$(MyString, PosDelimiter - 1)
    Line = Mid$(MyString, PosDelimiter + 4)
    'MsgBox Page
    'MsgBox Line
    On Error GoTo Errhandler
    Set TargetDoc = Documents(TargetDocName)
    TargetDoc.Activate
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=Page, Name:=""
    If Line - 1 > 0 Then
        Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative, Count:=Line - 1, Name:=""
    End If
    If SearchTerm <> "" Then
        Selection.Find.ClearFormatting
        With Selection.Find
            .Text = SearchTerm
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        Selection.Find.Execute
    End If
Errhandler:
    Select Case Err
        Case 4160: 'Error 4160 = Bad file name
            MsgBox "The file """ & TargetDocName & """ isn't open. Please open the file first."
    End Select
End Sub
Sub macrobutton(Page, Line As Integer, Filename, SearchTerm As String)
'
' Makro created on 22.01.2013
'
    Dim oField As Field, MyRange As Range
    Set MyRange = Selection.Range
    Set oField = Selection.Fields.Add(Range:=MyRange, Type:=wdFieldEmpty, Text:= _
        "MACROBUTTON GoToAPageAndLine S. " & Page & ", Z. " & Line & "", PreserveFormatting:= _
        False)
    Set oRange = ActiveDocument.Range(oField.Code.Start + 1, oField.Code.Start + 1)
    ActiveDocument.Fields.Add Range:=oRange, Type:=wdFieldPrivate, Text:="" & Filename & "|" & SearchTerm, PreserveFormatting:=False
End Sub
Sub CopyHighlightedTextInNewDocument()
'
' Makro created on 22.01.2013
'
    ActiveDocument.Range(0, 0).Select
    With Selection
        .Find.ClearFormatting
        .Find.Highlight = True
        With .Find
            .Replacement.ClearFormatting
            .Text = ""
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        Set CurrentDoc = ActiveDocument
        Set NewDoc = Documents.Add(Visible:=False)
        NewDoc.Content.InsertAfter "Summary of the highlighted text in " & """" & CurrentDoc.Name & """"
        NewDoc.Content.Font.Bold = True
        NewDoc.Content.InsertParagraphAfter
        NewDoc.Content.InsertParagraphAfter
        .Find.Execute
        Dim PageNumber, LineNumber As Integer
        Do While .Find.Found
            .Select
            Selection.Copy
            PageNumber = .Information(wdActiveEndPageNumber)
            LineNumber = .Information(wdFirstCharacterLineNumber)
            NewDoc.Activate
            With Selection
              .EndKey Unit:=wdStory
              .Font.Bold = True
              .Font.Underline = True
              .Font.ColorIndex = wdDarkBlue
              Call macrobutton(PageNumber, LineNumber, CurrentDoc.Name, "")
              .Font.Bold = True
              .Font.Underline = False
              .Font.ColorIndex = wdBlack
              '.InsertAfter "S. " & PageNumber
              '.InsertAfter ", Z. " & LineNumber
              .TypeText "______________________________________________________________" & vbCr
              .InsertParagraphAfter
              .MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
              .Paste
              .InsertParagraphAfter
              .InsertParagraphAfter
              .MoveDown Unit:=wdLine, Count:=2, Extend:=wdMove
            End With
            CurrentDoc.Activate
            .Find.Execute
        Loop
    End With
    NewDoc.Activate
    Options.ButtonFieldClicks = 1
    Selection.HomeKey Unit:=wdStory
    ActiveWindow.Visible = True
End Sub
Sub CopyKeywordPlusContext()
'
' Makro created on 22.01.2013
'
    Dim SearchTerm As String, WordsAfter As Long, WordsBefore As Long, i As Long
    Dim Rng As Range, Doc As Document, RngOut As Range
    SearchTerm = InputBox("Enter your search terms, Maria Cancro!" & vbCr & _
      "Then, sit back, relax, and let this macro do some heavy lifting." & vbCr & _
      vbCr & "It's okay - it works out!")
    SearchTerm = LCase(Trim(SearchTerm))
    If Len(SearchTerm) = 0 Then Exit Sub
    WordsBefore = InputBox("Enter the number of words before your search term to find.")
    WordsAfter = InputBox("Enter the number of words after your search term to find.")
    ActiveDocument.Range(0, 0).Select
    With Selection
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = SearchTerm
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .Execute
      End With
      If .Find.Found Then
        Set CurrentDoc = ActiveDocument
        Set Doc = Documents.Add(Visible:=False)
        Doc.Content.InsertAfter "Search results for """ & SearchTerm & """ + context in " & """" & CurrentDoc.Name & """"
        Doc.Content.Font.Bold = True
        Doc.Content.InsertParagraphAfter
        Doc.Content.InsertParagraphAfter
        Dim CheckAuto As Integer
        CheckAuto = MsgBox("Should all findings be copied automatically ('yes') or do you want to check each occurence manually ('no') ?", vbYesNo, "Automatically oder manually?")
        Dim CopyThis As Boolean
        Do While .Find.Found
          CopyThis = False
          Set Rng = .Range.Duplicate
          With Rng
            .Select
            Dim SelectionStart, SelectionEnd
            SelectionStart = Selection.Range.Start
            SelectionEnd = Selection.Range.End
            ActiveDocument.Range(SelectionStart, SelectionStart).Select
            Dim PageNumber, LineNumber As Integer
            PageNumber = Selection.Information(wdActiveEndPageNumber)
            LineNumber = Selection.Information(wdFirstCharacterLineNumber)
            .MoveStart wdWord, -WordsBefore
            .MoveEnd wdWord, WordsAfter + 2
            .Select
            Selection.MoveStart Unit:=wdLine, Count:=-1 'Comment this out if you
            Selection.MoveEnd Unit:=wdLine, Count:=1    '                        don't want the selection to be extended to the start / end of line
            If CheckAuto = vbYes Then
                CopyThis = True
            Else
                Dim Check As Integer
                Check = MsgBox(.Text, vbYesNoCancel, "Copy this block?")
                If Check = vbCancel Then
                    Exit Do
                ElseIf Check = vbYes Then
                    CopyThis = True
                End If
            End If
            If CopyThis = True Then
              Selection.Copy
              Doc.Activate
              With Selection
                  .EndKey Unit:=wdStory
                  .Font.Bold = True
                  .Font.Underline = True
                  .Font.ColorIndex = wdDarkBlue
                  Call macrobutton(PageNumber, LineNumber, CurrentDoc.Name, SearchTerm)
                  .Font.Bold = True
                  .Font.Underline = False
                  .Font.ColorIndex = wdBlack
                  '.InsertAfter "S. " & PageNumber
                  '.InsertAfter ", Z. " & LineNumber
                  .TypeText "______________________________________________________________" & vbCr
                  .InsertParagraphAfter
                  .MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
                  .Paste
                  .InsertParagraphAfter
                  .InsertParagraphAfter
                  .MoveDown Unit:=wdLine, Count:=2, Extend:=wdMove
              End With
              CurrentDoc.Activate
            End If
          End With
          .Collapse wdCollapseEnd
          .Find.Execute
        Loop
        Doc.Activate
      End If
    End With
    With Doc.Range.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = SearchTerm
      .Replacement.Text = "^&"
      .Replacement.Highlight = True
      .Forward = True
      .Wrap = wdFindStop
      .Format = True
      .MatchCase = False
      .MatchWholeWord = False
      .MatchAllWordForms = False
      .MatchSoundsLike = False
      .MatchWildcards = False
      .Execute Replace:=wdReplaceAll
    End With
    Options.ButtonFieldClicks = 1
    Selection.HomeKey Unit:=wdStory
    ActiveWindow.Visible = True
End Sub
 
Upvote 0
Re: MS Word Macro for Find & Export to Excel

You have posted four macros, with almost 250 lines of uncommented code and no context.

They appear to have been cobbled together from code produced by the macro recorder and other code that's had more thought put into it. Only one of those macros (CopyKeywordPlusContext) seems to have any connection with any of the others (macrobutton).

Your first macro (GoToAPageAndLine) even starts off with the requirement that something be selected so it can retrieve something from the second field in that selection, but with no indication of what that field is or contains or how the selection might be automated. It seems, too, that some of your code requires user input and interacts with other documents, yet it is by no means clear what you would expect from a macro that loops through a whole folder of documents.

It's a bit much asking someone to re-work such code. As you should be able to see from the code I posted, all of the processing of a given document is done within the main With/End With block:
Code: 
    With wdDoc
...
      .Close SaveChanges:=False
    End With
If you are unable to work from there, I suggest you start a new thread, clearly indicating: which of your macros needs automating; what it is supposed to do; how you expect it to behave regarding user input (e.g. once only, or for every document); and how it is supposed to interact with any other documents created/opened during processing.
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Question
Copy an excel table and paste it into word
Replies
2
Views
749
Paskie_EU
P
D
  • Question
How to find text in multiples documents and copy results for a separeted document?
Replies
0
Views
568
danielbasilio
D
K
  • Question
Auto or one click Word doc macro to run 3 different reports
Replies
6
Views
2K
Macropod
Macropod
S
  • Question
Macro from Excel not performing Word Actions
Replies
1
Views
434
Macropod
Macropod
K
  • Question
Creating tables at bookmarks in a Word document through Excel VBA from dynamic controls
Replies
4
Views
7K
jackni
J

Forum statistics

Threads
1,214,411
Messages
6,119,360
Members
448,888
Latest member
Arle8907

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top