Finding Range in Word then Copy to Excel VBA 4

[ThatNewGuy]

I'm currently working on code so the end user will have an open form in Excel then upon execution of a command button the user will be able to browse their pc for Word files needed to update the current Excel document/form. Once the Word document is opened I want to automate the process of selecting a range and pasting it into Excel. I know this is a pain going back and forth between the two formats of Word and Excel, but the story is too long to get into here. One last thing, all the vba is currently in Excel only.

Everything works until I try selecting a range within a Word table. The starting point of my range is selected in the Word table, but the ending point of the range is never selected. My code only selects one word. I've roamed the FAQ and tried some variations but any help would be appreciated because I'm stuck.

I'm also having trouble working out how to copy/paste from Word to Excel when all my code is in Excel. I can't run a Word.Range without getting errors bcuz of the Excel format.

Thanks,

Sub CommandButton1_Click()
Dim Filter As String, Title As String
Dim FilterIndex As Integer
Dim Filename As Variant

'File filters
Filter = "Word Documents (*.doc),*.doc," & "Text Files (*.txt),*.txt,"
' Default Filter to *.*
FilterIndex = 1
' Set Dialog Caption
Title = "Select LBL File to Open"
' Select Start Drive and Path
ChDrive ("C")
ChDir ("C:\Documents and Settings\")
With Application
' Set File Name to selected File
Filename = .GetOpenFilename(Filter, FilterIndex, Title)
' Reset Start Drive Path
ChDrive (Left(.DefaultFilePath, 1))
ChDir (.DefaultFilePath)
End With
' Exit on Cancel
If Filename = False Then
MsgBox "No file was selected."
Exit Sub
End If
' Open File
On Error Resume Next
' Open Word Doc
Set WrdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then ' Word is not already running
    Set WrdApp = CreateObject("Word.Application")
End If
'Open The Document
Set wdDoc = WrdApp.Documents.Open(Filename)
    With WrdApp
'Show Word
.Visible = True

With .Selection.Find
.ClearFormatting
.Text = "specifications:"
.Execute Forward:=True
.Wrap = wdFindContinue
End With
Selection.Find.Execute

point1 = Selection.Range.Start

With .Selection.Find <--------Troubles at this point down 
.ClearFormatting
.Text = "author"
.Execute Forward:=True
.Wrap = wdFindContinue
End With
Selection.Find.Execute

point2 = Selection.Range.End

ActiveDocument.Range(Start:=point1, End:=point2).Copy
End With
End Sub

 

[white605]

Try replacing

ActiveDocument.Range(Start:=point1, End:=point2).Copy

with something like

ActiveDocument.Range(Start:=point1, End:=point2).Select
ActiveDocument.selection.copy


This old world keeps spinning round - It's a wonder tall trees ain't layin' down

 

[PHV]

You have to full qualify all word objects:
With WrdApp
'Show Word
.Visible = True
With .Selection.Find
.ClearFormatting
.Text = "specifications:"
.Execute Forward:=True
.Wrap = wdFindContinue
End With
[highlight].[/highlight]Selection.Find.Execute
point1 = [highlight].[/highlight]Selection.Range.Start
With .Selection.Find
.ClearFormatting
.Text = "author"
.Execute Forward:=True
.Wrap = wdFindContinue
End With
[highlight].[/highlight]Selection.Find.Execute
point2 = [highlight].[/highlight]Selection.Range.End
[highlight].[/highlight]ActiveDocument.Range(Start:=point1, End:=point2).Copy
End With


Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[MakeItSo]

PHV is spot on.

But another thing is missing:

Add a

.selection.Collapse wdCollapseStart

before executing the second find, else you sear within your current selection only - and that is your firstly found range...

;-)

[navy]"We had to turn off that service to comply with the CDA Bill."[/navy]
- The Bastard Operator From Hell

 

[ThatNewGuy]

Great job to everyone! Much thanks all around. It's ALWAYS the little things when it comes down to it. I knew I was close, but close doesn't cut it. Once again, thank you!

 

[SkipVought]

ThatNewGuy,

I notice that over the past 2 years, you have posted fourteen threads and have received many good tips related to your stated needs. Yet, you have responded not once, to
[blue]
Thank Tek-Tip Contributor
for this valuable post![/blue].

The little purple Stars accomplish several important things.

First, it gives positive feedback to contributors, that their posts have been helpful.

Second, it identifies threads as containing helpful posts, so that other members can benefit.

And third, it identifies the original poster (that's YOU, BTW), as a grateful member, that not only receives, but is willing to give tokens of thanks.

Skip,
[sup]Don't let the Diatribe...
talk you to death![/sup][sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[ThatNewGuy]

Skip, I have no idea what your talking about. Little stars? I'll be the first guy to thank someone or pat someone on the back, but I'm not a forum "expert". I never knew about these special stars let alone how in the world to use them.

 

[SkipVought]

ThatNewGuy,

Just look back thru the replies to THIS thread, and you will see a hyperlink in each post, with the opportunity to do so.

It is very unlikely, you have not seen the little purple stars in the forums you have posted in...
[tt]
Microsoft SQL Server: Programming
Microsoft: Access Forms
Microsoft: Access Modules (VBA Coding)
Microsoft: Access Other topics
Microsoft: Office
VBA Visual Basic for Applications (Microsoft)
[/tt]


Skip,
[sup]Don't let the Diatribe...
talk you to death![/sup][sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[fumei]

PHV is quite correct in that you must fully qualify your objects. However, as you have already fully qualified wdDoc, you could use that.

So instead of:

With wrdApp

 [highlight].[/highlight]ActiveDocument.Range(Start:=point1, End:=point2).Copy

thus qualifying it to the wrdApp object, you could use:

[b]Set wdDoc = wrdapp.Documents.Open(FileName)[/b]

wdDoc.Range(Start:=point1, End:=point2).Copy

The point being is that if you use ActiveDocument, you must fully qualify it to the application object (wrdApp).

However, if you use wdDoc (a fully qualified object), you can use its properties.

I would also like to point out that it would likely be better to use a range object, rather than Selection. I notice your variables point1 and point2 are not declared in the procedure, so I added that.

Dim point1 As Long
Dim point2 As Long
Dim r As [b]Word.Range[/b]
[COLOR=red]' as you are doing this from Excel
' you MUST be sure to declare it as [b]Word[/b].Range
' if you declare it as Range VBA will (correctly)
' assume it is an Excel range variable[/color red]

....other stuff

Set wdDoc = wrdapp.Documents.Open(FileName)
Set r = wdDoc.Range

'Show Word
wrdapp.Visible = True

   With r.Find
      .ClearFormatting
      .Text = "specifications:"
      .Execute Forward:=True
      .Wrap = wdFindContinue
   End With
   point1 = r.Start

   ' RESET range to document again
Set r = wdDoc.Range
   With r.Find
      .ClearFormatting
      .Text = "author"
      .Execute Forward:=True
      .Wrap = wdFindContinue
   End With
   point2 = r.End

   wdDoc.Range(Start:=point1, End:=point2).Copy

That is, if I understand what you are trying to, which is:

1. find "specifications:"
2. set a point at the start of that.
3. find "author"
4. set a point at the end of that
5. copy everything between those points

AND with the assumption that "author" will definitely be AFTER "specifications:"

If that assumption is incorrect then adjustments would have to be made.

Also, if you are trying to do multiples of this operation, it would be better to use a loop, like this:

Dim point1 As Long
Dim point2 As Long
Dim j As Long
Dim r As Word.Range

Set wdDoc = wrdapp.Documents.Open(FileName)
Set r = wrdapp.ActiveDocument.Range

'Show Word
wrdapp.Visible = True

With r.Find
   .ClearFormatting
   Do While .Execute(FindText:="specifications:", _
      Forward:=True) = True
      point1 = r.Start
      [COLOR=red]' get the range end value[/color red]
      j = r.End
      r.Collapse 0
      [COLOR=red]' RESET range object from just AFTER
      ' "specifications:' to end of document
      ' to search for "author"[/color red]
      Set r = wdDoc.Range(Start:=j, _
        End:=wdDoc.Range.End)
      With r.Find
        .ClearFormatting
        .Text = "author"
        .Execute
        If .Found = True Then
           point2 = r.End
        End If
      End With
      [COLOR=red]' RESET searching range from END of
      ' the "specifications:" found
      ' to end of document[/color red]
      Set r = wdDoc.Range(Start:=j, _
           End:=wdDoc.Range.End)
      [COLOR=red]' search for the next "specifications:"[/color red]
  Loop
End With
wdDoc.Range(Start:=point1, End:=point2).Copy

Lastly, do you actually need wrdapp Visible? If the user is not, in fact, doing anything with the document, why bother?


Gerry

 

[fumei]

Skip, have you written a script to automate the copy/paste of your blurb?

....just razzin'

I certainly do not object, and in fact think you are doing the site a service by your nagging, whining reminders to people.

....just razzin'

Seriously...no, no..I am sorry....I just can't be serious today. OK, let me take a breath.

Seriously, thank you. Hey, maybe I should give you a star for all your reminders to people. Would that be irony? Or sarcasm? Can one give a star sarcastically?

hmmmmm.

Gerry

 

[ThatNewGuy]

Hello Gerry,

These are some really good suggestions! When I have a chance I'm going to convert over to your revisions. I love the idea of dropping the ActiveDocument and Selection commands because it will help things run much much faster. Good thinking.

As for the wrdApp being visible that was just part of my "test" code. When I was having problems selecting words/and or ranges I wanted to be able to verify if the sequence was working or not. I'll drop that once I know everything is working accordingly.

Now I'm trying to paste into Excel and format the selection which is leading to another set of problems. Any suggestions? I might even give you a special star....haha. I couldn't pass it up after your last post

 

[ThatNewGuy]

Gerry, I've run into a new set of problems after updating to your suggestions. It all slowly started coming back to me why I wasn't using parameters like you suggested vs the clunky activedocument and selection commands.

When defining Dim r As Word.Range I went ahead and updated the References to the current Word Object Library. I also dropped the wrdapp visible line. It appears when I select the Word Object Library it triggers an error in Excel. See below. When the updated code runs it basically closes Excel and asks if I want to open the file in recovery mode. I thought that was odd.

Error in Excel reads:

Microsoft Excel has encountered a problem and needs to close. We are sorry for the inconvenience.
The information you were working on might be lost. Excel can try to recover it for you.
Option to recover my work and restart Excel.

 

[fumei]

Post your code.

Gerry

 

[ThatNewGuy]

Gerry, here is the update.

Sub CommandButton1_Click()
Dim Filter As String, Title As String
Dim FilterIndex As Integer
Dim Filename As Variant
Dim point1 As Long
Dim point2 As Long
Dim r As Word.Range
Dim xlWB As Excel.Workbook

'File filters
Filter = "Word Documents (*.doc),*.doc," & "Text Files (*.txt),*.txt,"
' Default Filter to *.*
FilterIndex = 1
' Set Dialog Caption
Title = "Select LBL File to Open"
' Select Start Drive and Path
ChDrive ("C")
ChDir ("C:\Documents and Settings\")
With Application
' Set File Name to selected File
Filename = .GetOpenFilename(Filter, FilterIndex, Title)
' Reset Start Drive Path
ChDrive (Left(.DefaultFilePath, 1))
ChDir (.DefaultFilePath)
End With
' Exit on Cancel
If Filename = False Then
MsgBox "No file was selected."
Exit Sub
End If
' Open File
On Error Resume Next
' Open Word Doc
Set WrdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then ' Word is not already running
    Set WrdApp = CreateObject("Word.Application")
End If

Set wdDoc = WrdApp.Documents.Open(Filename)
Set r = wdDoc.Range

With r.Find
.ClearFormatting
.Text = "specifications:"
.Execute Forward:=True
.Wrap = wdFindContinue
End With
point1 = r.Start

Set r = wdDoc.Range
With r.Find
.ClearFormatting
.Text = "version"
.Execute Forward:=True
.Wrap = wdFindContinue
End With
point2 = r.End

wdDoc.Range(Start:=point1, End:=point2).Select
wdDoc.Range(Start:=point1, End:=point2).Copy

With xlWB.Worksheets(1)
ActiveSheet.Paste.Destination = Worksheets("Sheet1").Range("A8:E17")
    
End With
End Sub

 

[fumei]

1. please use the TGML code tags when posting code. I can see you tried with the opening code tag, but you forgot the closing tag.

2. are you fully and properly declaring your objects/variables? You are using WrdApp and WrdDoc, but they do not seem to be declared. Are you using Option Explicit? if not, start doing so now.

3. You do declare a Workbook object with:

   Dim xlWB As Excel.Workbook

and then you use it with:

With xlWB.Worksheets(1)

...but you never Set it! You have to Set the object before you use it.

4. I am not quite understanding what you are doing, in that your code gets the range in Word, although using Select:

   wdDoc.Range(Start:=point1, End:=point2).Select
   wdDoc.Range(Start:=point1, End:=point2).Copy

but you do not seem to be doing anything with it in the procedure.

Gerry