VBA Question

[rbg321]

Hi,

I'm very new to VBA. I'm using it to try to create an Excel spreadsheet out of specific pieces of information extracted from a 100-page microsoft word document. This is what I have so far:
Sub GrabUsage()Dim FName As String, FD As FileDialog
Dim WApp As Object, WDoc As Object, WDR As Object
Dim ExR As Range


Set ExR = Selection ' current location in Excel Sheet


Set FD = Application.FileDialog(msoFileDialogOpen)
FD.Show
If FD.SelectedItems.Count <> 0 Then
FName = FD.SelectedItems(1)
Else
Exit Sub
End If


Set WApp = CreateObject("Word.Application")
' WApp.Visible = True
Set WDoc = WApp.Documents.Open(FName)


WApp.Selection.HomeKey Unit:=6
WApp.Selection.Find.ClearFormatting
WApp.Selection.Find.Execute "Updated"


WApp.Selection.MoveDown Unit:=5, Count:=1


WApp.Selection.MoveRight Unit:=2, Count:=15, Extend:=1

Set WDR = WApp.Selection
ExR(1, 1) = WDR ' place at Excel cursor

WApp.Selection.HomeKey Unit:=6
WApp.Selection.Find.ClearFormatting
WApp.Selection.Find.Execute "NICU Beds"
WApp.Selection.MoveRight Unit:=2, Count:=2
WApp.Selection.MoveRight Unit:=2, Count:=1, Extend:=1


Set WDR = WApp.Selection
ExR(1, 2) = WDR ' place in cell right of Excel cursor

WDoc.Close
WApp.Quit


End Sub

This gets me the first string of words after Updated and NICU Beds, but I want all the instances of the word strings following those words. How can I get the macro to find all of them and put them each in their own cell?

 

[pbornemeier]

This should get you close to what you want:

Option Explicit

Sub GrabUsage()

    Dim FName As String, FD As FileDialog
    Dim WApp As Object, WDoc As Object, WDR As Object
    Dim ExR As Range
    Dim lNextWriteRow As Long
    
    
    Set ExR = Selection ' current location in Excel Sheet
    
    Set FD = Application.FileDialog(msoFileDialogOpen)
    FD.Show
    
    If FD.SelectedItems.Count <> 0 Then
        FName = FD.SelectedItems(1)
    Else
        Exit Sub
    End If
    
    Set WApp = CreateObject("Word.Application")
    'WApp.Visible = True
    Set WDoc = WApp.Documents.Open(FName)
    
    'Some code extracted from
    'http://stackoverflow.com/questions/13465709/repeating-microsoft-word-vba-until-no-search-results-found
    
    'Move to start of Word Document
    WApp.Selection.HomeKey Unit:=6  'wdStory
    WApp.Selection.Find.ClearFormatting
    
    lNextWriteRow = 1
    'Search for 'Updated'
    With WApp.Selection.Find
        .Text = "Updated"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = 1 'wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = True
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
    End With
    WApp.Selection.Find.Execute
    
    'Repeat this section to find all Updated
    Do While WApp.Selection.Find.Found = True
        
        'On the last loop you'll not find a result so check here
        If WApp.Selection.Find.Found Then

            'WApp.Selection.Extend
            
            WApp.Selection.MoveDown Unit:=5, Count:=1
            WApp.Selection.MoveRight Unit:=2, Count:=15, Extend:=1

            ExR(lNextWriteRow, 1).Value = WApp.Selection  ' referenced to Excel cursor
            
            lNextWriteRow = lNextWriteRow + 1

            WApp.Selection.Collapse 0 'wdCollapseEnd
            
        End If
        WApp.Selection.ExtendMode = False
        WApp.Selection.Find.Execute
    Loop
    
    'Move to start of Word Document
    WApp.Selection.HomeKey Unit:=6  'wdStory
    WApp.Selection.Find.ClearFormatting
    
    lNextWriteRow = 1
    'Search for 'NICU Beds'
    With WApp.Selection.Find
        .Text = "NICU Beds"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = 1 'wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = True
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
    End With
    WApp.Selection.Find.Execute
    
    'Repeat this section to find all 'NICU Beds'
    Do While WApp.Selection.Find.Found = True
        
        'On the last loop you'll not find a result so check here
        If WApp.Selection.Find.Found Then

            WApp.Selection.Extend
            
            WApp.Selection.MoveRight Unit:=2, Count:=2
            WApp.Selection.MoveRight Unit:=2, Count:=1, Extend:=1

            ExR(lNextWriteRow, 2).Value = WApp.Selection  ' referenced to Excel cursor
            
            lNextWriteRow = lNextWriteRow + 1

            WApp.Selection.Collapse 0 'wdCollapseEnd
            
        End If
        WApp.Selection.ExtendMode = False
        WApp.Selection.Find.Execute
    Loop
    
    WDoc.Close
    WApp.Quit

 End Sub