Find what and copy that

PRA007 · #1 10-29-2015, 03:30 AM

I am trying to making macro for doing specific task

Code:

Sub Fees()
'
' Fees Macro
'
'
    With Selection.Find
        .Text = ","
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "US ([0-9]{5} )"
        .Replacement.Text = "US RE\1"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "US ([0-9]{5} )"
        .Replacement.Text = "US RE\1"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    
With .Find
        .Text = "US [R3-9][0-9E]{6}"
        .Replacement.Text = "US RE\1"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchWildcards = True
        .Execute
  End With
  Do While .Find.Found
    End With
    Selection.Copy
    Documents.Add DocumentType:=wdNewBlankDocument
    Selection.PasteAndFormat (wdFormatPlainText)
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "US "
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    ChangeFileOpenDirectory "C:\Users\rahulkumar.patel\Desktop\"
    ActiveDocument.SaveAs2 FileName:="i.txt", FileFormat:=wdFormatText, _
        LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
        :="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
        SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
        False, Encoding:=1252, InsertLineBreaks:=False, AllowSubstitutions:=False _
        , LineEnding:=wdCRLF, CompatibilityMode:=0
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "US "
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    ActiveWindow.Close
End Sub

I actually want to copy after doing some replacements text to new docuument and want to save it.

The Problem is I don't know where to start loop function.

Source file is at here:
https://sites.google.com/site/rtsk2015/fo

Sr.docx

macropod · #2 10-29-2015, 04:24 AM

I have already shown you how to implement a loop with Find here: https://www.msofficeforums.com/word-...highlight.html

PRA007 · #3 10-29-2015, 04:59 AM

I am begginer in making vba.
I was able to loop with find, but could not figure out how to copy all while found.
I just want to loop throught what I found using US [R3-9][0-9E]{6} and copy that.
I will keep trying.

macropod · #4 10-29-2015, 12:56 PM

Perhaps you could explain what you are trying to do...

PRA007 · #5 10-29-2015, 11:33 PM

I have word 5 column table containing patent numbers like this in column 2.

WO 2001/042246 A3
(Pfizer)
EP 1235830 B1;
EP 1382339 B1;
US 6,627,754 B2;
US 6,956,041 B2;
US 7,091,208 B2;
US 7,265,221 B2;
US 7,601,727 B2;
US 7,842,699 B2;
US 41783 E1;
IN 241773 A1;
US 6,627,754 B2

I want to perform following steps

1)
Find "US ([3-9]),([0-9]{3}),([0-9]{3})"
Replace with "US \1\2\3"

2)
Find "US ([0-9]{5} )"
Replace with "US RE\1"

3)
Find all occurences of US [R3-9][0-9E]{6}
copy, add new doccument, paste.

4)
In new document
Find "US "
Replace with ""
save new document as text file (i.txt) in desktop.
Close new document

5) in original document
find "US ([3-9])([0-9]{3})([0-9]{3})"
Replace with "US \1,\2,\3
save current doccument.

macropod · #6 10-29-2015, 11:54 PM

Your steps 1 & 5 are mutually exclusive. Step 1 removes the commas, so there aren't any for Step 5 to find...

Moreover, the Find/Replace code you posted is doing something quite different from what you describe. Amongst other things, it starts off by deleting all commas, so there would be nothing even for your Step 1 to find!

PRA007 · #7 10-30-2015, 12:55 AM

I made mistake in step 5.
I corrected it.

I actually want to find plain number after "US "
Initially I tried removing all commas But I didn't realize it will remove all commas from large doccument containing other text also.

Apology for changing the question.

Step 5 is making document again at original state.

macropod · #8 10-30-2015, 01:05 AM

Quote:

Originally Posted by PRA007

Step 5 is making document again at original state.

No, it doesn't, because it doesn't undo the RE insertions. If all you want after doing the data extraction is to restore the source document to its original state, why not just close it without saving?

As for the rest, try:

Code:

Sub Fees()
Application.ScreenUpdating = False
Dim StrOut As String, DocNew As Document
With ActiveDocument
  With .Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
      .MatchWildcards = True
      .Text = "(US [3-9]),([0-9]{3}),([0-9]{3})"
      .Replacement.Text = "\1\2\3"
      .Execute Replace:=wdReplaceAll
      .Text = "(US )([0-9]{5} )"
      .Replacement.Text = "\1RE\2"
      .Execute Replace:=wdReplaceAll
      .Wrap = wdFindStop
      .Text = "US [R3-9][0-9E]{6}"
      .Replacement.Text = ""
      .Execute
    End With
    Do While .Find.Found
      StrOut = StrOut & Split(.Text, " ")(1) & vbCr
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
End With
Set DocNew = Documents.Add
With DocNew
  .Range.Text = StrOut
  .SaveAs2 FileName:="C:\Users\" & Environ("Username") & "\Desktop\i.txt", _
    FileFormat:=wdFormatText, AddToRecentFiles:=False
  .Close
End With
Set DocNew = Nothing
Application.ScreenUpdating = True
End Sub

PRA007 · #9 10-30-2015, 04:45 AM

Solved My all other problems with respect to find and replace as well as find copy and paste.

I have to do lot of find and replace and i record macro for that which some times exceeds line limits. Now i simply follow your above find and replace whic will save lot of lines.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Find specific rows then copy and paste to new doc	konopca	Word VBA	5	02-20-2014 02:34 PM
Find Results in excel copy the rows to another sheet	khalidfazeli	Excel	2	02-06-2013 09:38 AM
Find, copy and paste into a new page	jperez84	Word VBA	24	09-20-2012 11:34 AM
Macro that can find phrase and then find another and copy	jperez84	Word VBA	10	09-19-2012 04:48 PM
Trying to find and copy all headings at the same time	WaltR	Word	7	08-21-2012 03:12 PM