Bacalhau75
New Member
- Joined
- Jul 9, 2014
- Messages
- 12
HI,
i'm tring to find some information on my WORD doc, set a range, copy that range onto a new word doc.
It seems to be working but when i check, the specific 3 digit prefix i'm looking for in the table isn't there.
I also don't know how to make the macro continue where it left off after exporting a found email.
It always goes back to home, finding the same record over and over.
any suggestions?
It's my first time coding only in WORD. i usually use Excel for everything.
Thanks,
Sub FindIt()
Dim blnFound As Boolean
Dim rng1 As Range
Dim rng2 As Range
Dim rngFound As Range
Dim strTheText As String
Dim Doc_ID As Long
Dim ir As Long
Dim stp_cnt As Long
Dim WrdApp As Word.Application
Dim ThisDoc As Word.Document
Dim oDoc As Word.Document
Dim Opn_Dc As String
Dim PrFx As String
Dim sTrt As String
Dim Endd As String
Dim Ctr As Long
Dim i4, i2, i3 As Long
Dim PaRa1, paRaS, paRaE As Long
Dim iParCount As Long
Dim para As Paragraph
Dim close_count As Long
sTrt = "This e-mail notification"
Endd = "This e-mail notification"
PrFx = InputBox("Choose Prefix", "PREFIX", "847")
Opn_Dc = InputBox("ENTER NAME OF DOC", "FILE NAME", "Manual2.docx")
Documents.Open FileName:="C:\Users\nbk8oog\Desktop\LOSTMayEmails\" & Opn_Dc, ConfirmConversions:=False, _
ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
WritePasswordTemplate:="", Format:=wdOpenFormatAuto, XMLTransform:=""
close_count = 1
iParCount = ActiveDocument.Paragraphs.Count
For Each para In ActiveDocument.Paragraphs
Do Until Left(Selection.Text, 3) = "847" Or Left(Selection.Text, 3) = "689"
Ctr = Ctr + 1
Selection.MoveDown Unit:=wdParagraph, Count:=1
Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
'iParCount = ActiveDocument.Paragraphs.Count
Loop
Application.ScreenUpdating = False
'Selection.HomeKey wdStory
Selection.Find.Text = sTrt
blnFound = Selection.Find.Execute
If blnFound Then
Selection.MoveRight wdWord
Set rng1 = Selection.Range
Selection.Find.Text = Endd
blnFound = Selection.Find.Execute
If blnFound Then
Set rng2 = Selection.Range
Set rngFound = ActiveDocument.Range(rng1.Start, rng2.Start)
'Set rngFound = ActiveDocument.Range(rng1.Start - 26, rng2.Start + 72)
strTheText = rngFound.Text
'MsgBox strTheText
rngFound.Select
rngFound.Copy
Documents.Add
Selection.Paste
Doc_ID = Doc_ID + 1
ActiveDocument.SaveAs "C:\Users\nbk8oog\Desktop\LOSTMayEmails\Catpured\DOC numb-" & Doc_ID
ActiveDocument.Close
close_count = close_count + 1
If close_count = 10 Then
MsgBox "Try STopping now"
'Application.Wait Now + TimeValue("0:00:10")
stp_cnt = MsgBox("DO YOU WANT TO STOP?", vbYesNo, "YES to continue, NO to stop")
If stp_cnt <> 6 Then
'Stop
Else
stp_cnt = MsgBox("DO YOU WANT TO CANCEL?", vbYesNo, "YES to continue, NO to stop")
If stp_cnt <> 6 Then
Else
Exit Sub
End If
End If
End If
End If
End If
'move back to beginning
' Selection.HomeKey wdStory
Application.ScreenUpdating = True
Next
End Sub
i'm tring to find some information on my WORD doc, set a range, copy that range onto a new word doc.
It seems to be working but when i check, the specific 3 digit prefix i'm looking for in the table isn't there.
I also don't know how to make the macro continue where it left off after exporting a found email.
It always goes back to home, finding the same record over and over.
any suggestions?
It's my first time coding only in WORD. i usually use Excel for everything.
Thanks,
Sub FindIt()
Dim blnFound As Boolean
Dim rng1 As Range
Dim rng2 As Range
Dim rngFound As Range
Dim strTheText As String
Dim Doc_ID As Long
Dim ir As Long
Dim stp_cnt As Long
Dim WrdApp As Word.Application
Dim ThisDoc As Word.Document
Dim oDoc As Word.Document
Dim Opn_Dc As String
Dim PrFx As String
Dim sTrt As String
Dim Endd As String
Dim Ctr As Long
Dim i4, i2, i3 As Long
Dim PaRa1, paRaS, paRaE As Long
Dim iParCount As Long
Dim para As Paragraph
Dim close_count As Long
sTrt = "This e-mail notification"
Endd = "This e-mail notification"
PrFx = InputBox("Choose Prefix", "PREFIX", "847")
Opn_Dc = InputBox("ENTER NAME OF DOC", "FILE NAME", "Manual2.docx")
Documents.Open FileName:="C:\Users\nbk8oog\Desktop\LOSTMayEmails\" & Opn_Dc, ConfirmConversions:=False, _
ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
WritePasswordTemplate:="", Format:=wdOpenFormatAuto, XMLTransform:=""
close_count = 1
iParCount = ActiveDocument.Paragraphs.Count
For Each para In ActiveDocument.Paragraphs
Do Until Left(Selection.Text, 3) = "847" Or Left(Selection.Text, 3) = "689"
Ctr = Ctr + 1
Selection.MoveDown Unit:=wdParagraph, Count:=1
Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
'iParCount = ActiveDocument.Paragraphs.Count
Loop
Application.ScreenUpdating = False
'Selection.HomeKey wdStory
Selection.Find.Text = sTrt
blnFound = Selection.Find.Execute
If blnFound Then
Selection.MoveRight wdWord
Set rng1 = Selection.Range
Selection.Find.Text = Endd
blnFound = Selection.Find.Execute
If blnFound Then
Set rng2 = Selection.Range
Set rngFound = ActiveDocument.Range(rng1.Start, rng2.Start)
'Set rngFound = ActiveDocument.Range(rng1.Start - 26, rng2.Start + 72)
strTheText = rngFound.Text
'MsgBox strTheText
rngFound.Select
rngFound.Copy
Documents.Add
Selection.Paste
Doc_ID = Doc_ID + 1
ActiveDocument.SaveAs "C:\Users\nbk8oog\Desktop\LOSTMayEmails\Catpured\DOC numb-" & Doc_ID
ActiveDocument.Close
close_count = close_count + 1
If close_count = 10 Then
MsgBox "Try STopping now"
'Application.Wait Now + TimeValue("0:00:10")
stp_cnt = MsgBox("DO YOU WANT TO STOP?", vbYesNo, "YES to continue, NO to stop")
If stp_cnt <> 6 Then
'Stop
Else
stp_cnt = MsgBox("DO YOU WANT TO CANCEL?", vbYesNo, "YES to continue, NO to stop")
If stp_cnt <> 6 Then
Else
Exit Sub
End If
End If
End If
End If
End If
'move back to beginning
' Selection.HomeKey wdStory
Application.ScreenUpdating = True
Next
End Sub
Last edited:
