Thread: Grab Data From Word Header using Excel Macro

Thanks for the heads up. Here's a copy of the word document template I am trying to pull the header data from.

Here's a complete copy of the code as I have it so far...

Sub Basis_Grabber()
'
' Loops through a folder containing AP-A Reports and extracts the "Report Basis" Field"
'


'Excel Objects
Dim PullMe As String
Dim Wbk_RollUp As Workbook
Dim Wks_RollUp As Worksheet
Dim StrPath As String
Dim Int_Count As Integer
Dim Rng_Files As Range
Dim Rng_Basis As Range

'Word Objects
Dim Str_FName As String
Dim F1D_FD As FileDialog
Dim Obj_Wapp As Object
Dim Obj_WDoc As Object
Dim Obj_WDR As Object

'Establishes the destination for all the info
Set Wbk_RollUp = ActiveWorkbook

'Create a new rollup worksheet
Wbk_RollUp.Sheets.Add After:=Worksheets(1)
Worksheets(2).Name = "MAGIC" & Worksheets.Count - 1
Set Wks_RollUp = Worksheets(2)

'Establish Column Headers
Wks_RollUp.Cells(1, 1).Value = "File Number"
Wks_RollUp.Cells(1, 2).Value = "Full Path"
Wks_RollUp.Cells(1, 3).Value = "Grid Coordinates (MGRS):"
Wks_RollUp.Cells(1, 4).Value = "City:"
Wks_RollUp.Cells(1, 5).Value = "District:"
Wks_RollUp.Cells(1, 6).Value = "Province:"
Wks_RollUp.Cells(1, 7).Value = "HNIR(s):"
Wks_RollUp.Cells(1, 8).Value = "FCR(s):"
Wks_RollUp.Cells(1, 9).Value = "Report Basis:"
Wks_RollUp.Cells(1, 10).Value = "Unit:"
Wks_RollUp.Cells(1, 11).Value = "Tasker:"
Wks_RollUp.Cells(1, 12).Value = "BLUF:"
Wks_RollUp.Cells(1, 13).Value = "ATMOSPHERIC VALUE:"
Wks_RollUp.Cells(1, 14).Value = "DETAILS:"
Wks_RollUp.Cells(1, 15).Value = "COMMENTS:"
Wks_RollUp.Cells(1, 16).Value = "DTG"



'User selects word documents
Set F1D_FD = Application.FileDialog(msoFileDialogFilePicker)
With F1D_FD
    .AllowMultiSelect = True
    .Show
    
    For Int_Count = 1 To .SelectedItems.Count   'load paths into excel
        Wks_RollUp.Cells(Int_Count + 1, 1) = Int_Count
        Wks_RollUp.Cells(Int_Count + 1, 2).Value = .SelectedItems(Int_Count)
    Next Int_Count
    
    Set Rng_Files = Wks_RollUp.Range(Cells(2, 2), Cells(Int_Count, 2))
    Set Rng_Basis = Wks_RollUp.Range(Cells(2, 3), Cells(Int_Count, 3))
    
End With

'Open The Word Application
Set Obj_Wapp = CreateObject("Word.Application")
    
'Don't let the user see!
Obj_Wapp.Visible = False

'For all the files that the user selected
For Int_Count = 1 To Rng_Files.Rows.Count
    
    'Open The User Selected Document
    Set Obj_WDoc = Obj_Wapp.documents.Open(Rng_Files.Cells(Int_Count, 1).Value, ReadOnly:=True)
    
    'For Each Column of Data, 1-14....
    For Pulled_Int_Count = 1 To 14
        
        'PullMe = The Column Headers (Identified Above)
        PullMe = Wks_RollUp.Cells(1, Pulled_Int_Count + 2)
        
        'I don't know, but it works
        Obj_Wapp.Selection.HomeKey Unit:=6
        
        'Find PullMe(The Column Headers) in the Word Document
        Obj_Wapp.Selection.Find.Execute PullMe
        
        'Make sure there's stuff there
        If Obj_Wapp.Selection Is Nothing Then
            Obj_Wapp.Selection.Value = ""
        End If
        

        'UNDER CONSTRUCTION
        
        'Are we talking about the Details section? If so, select everything between Details and Comments
        If Pulled_Int_Count = 12 Then
            Obj_Wapp.Selection.Collapse Direction:=wdCollapseEnd
 
        Else
            'If We aren't Talking about details, then include everything inside of the one paragraph
            Obj_Wapp.Selection.Collapse Direction:=wdCollapseEnd
        End If
        'END CONSTRUCTION
        
        Obj_Wapp.Selection.Extend
        Obj_Wapp.Selection.Extend
        Obj_Wapp.Selection.Extend
    
        'UNDER CONSTRUCTION
        
        
        
        'THIS IS WHERE I NEED HELP..
        
        'If the data is in the header (DTG, SUBJ)
        If Pulled_Int_Count = 14 Then
        
            'Just Pull out that line from the header and place it in the Spreadsheet
            Obj_Wapp.Selection.GoTo What:=wdGoToHeading, Which:=wdGoToSecond = Rng_Basis.Cells(Int_Count, Pulled_Int_Count).Value
        
        Else
        'Move the data from PullMe into the Excel Spreadsheet
        Rng_Basis.Cells(Int_Count, Pulled_Int_Count).Value = Obj_Wapp.Selection
        End If
        
        'END CONSTRUCTION
        
        
        
        
        
        
        
        
        
        'Clear the .Find variable for the RAM Conscious
        Obj_Wapp.Selection.Find.ClearFormatting
        
    'Now move on to the next item to pull from this same report
    Next Pulled_Int_Count

    'Now Close This document to Save RAM
    Obj_WDoc.Close
 

Next Int_Count
    
'Now close the Word Application
Obj_Wapp.Quit
End Sub

Thanks again guys!

Attachements didn't follow. Attached is the sample Word Document and a .JPEG of what the final product looks like (minus the Header Data, which is the crux of my issue)

Respectfully,
WvuSoldier

'Add Tools > References... > Microsoft Word xx.0 Object Library
Sub Basis_Grabber()
  '
  ' Loops through a folder containing AP-A Reports and extracts all Data
  '
  
  
  'Excel Objects
  Dim PullMe As String
  Dim Wbk_RollUp As Workbook
  Dim Wks_RollUp As Worksheet
  Dim StrPath As String
  Dim Int_Count As Integer
  Dim Rng_Files As Range
  Dim Rng_Basis As Range
  Dim Pulled_Int_Count As Integer
  
  'String For Header
  Dim Header As String
  
  'Word Objects
  Dim Str_FName As String
  Dim F1D_FD As FileDialog
  Dim Obj_Wapp As Word.Application
  Dim Obj_WDoc As Word.Document
  Dim Obj_WDR As Word.Range
  
  'Establishes the destination for all the info
  Set Wbk_RollUp = ActiveWorkbook
  
  'Create a new rollup worksheet
  Wbk_RollUp.Sheets.Add After:=Worksheets(1)
  Worksheets(2).Name = "MAGIC" & Worksheets.Count - 1
  Set Wks_RollUp = Worksheets(2)
  
  'Establish Column Headers
  Wks_RollUp.Cells(1, 1).Value = "File Number"
  Wks_RollUp.Cells(1, 2).Value = "Full Path"
  Wks_RollUp.Cells(1, 3).Value = "Grid Coordinates (MGRS):"
  Wks_RollUp.Cells(1, 4).Value = "City:"
  Wks_RollUp.Cells(1, 5).Value = "District:"
  Wks_RollUp.Cells(1, 6).Value = "Province:"
  Wks_RollUp.Cells(1, 7).Value = "HNIR(s):"
  Wks_RollUp.Cells(1, 8).Value = "FCR(s):"
  Wks_RollUp.Cells(1, 9).Value = "Report Basis:"
  Wks_RollUp.Cells(1, 10).Value = "Unit:"
  Wks_RollUp.Cells(1, 11).Value = "Tasker:"
  Wks_RollUp.Cells(1, 12).Value = "BLUF:"
  Wks_RollUp.Cells(1, 13).Value = "ATMOSPHERIC VALUE:"
  Wks_RollUp.Cells(1, 14).Value = "DETAILS:"
  Wks_RollUp.Cells(1, 15).Value = "COMMENTS:"
  Wks_RollUp.Cells(1, 16).Value = "DTG"
  Wks_RollUp.Cells(1, 17).Value = "AR(s)"
  Wks_RollUp.Cells(1, 18).Value = "Subj"
  
  
  
  'User selects word documents
  Set F1D_FD = Application.FileDialog(msoFileDialogFilePicker)
  With F1D_FD
      .AllowMultiSelect = True
      .Show
      
      For Int_Count = 1 To .SelectedItems.Count   'load paths into excel
          Wks_RollUp.Cells(Int_Count + 1, 1) = Int_Count
          Wks_RollUp.Cells(Int_Count + 1, 2).Value = .SelectedItems(Int_Count)
      Next Int_Count
      
      Set Rng_Files = Wks_RollUp.Range(Cells(2, 2), Cells(Int_Count, 2))
      Set Rng_Basis = Wks_RollUp.Range(Cells(2, 3), Cells(Int_Count, 3))
      
  End With
  
  'Open The Word Application
  Set Obj_Wapp = CreateObject("Word.Application")
      
  'Don't let the user see!
  Obj_Wapp.Visible = False
  
  'For all the files that the user selected
  For Int_Count = 1 To Rng_Files.Rows.Count
      
      'Open The User Selected Document
      Set Obj_WDoc = Obj_Wapp.Documents.Open(Rng_Files.Cells(Int_Count, 1).Value, ReadOnly:=True)
      
      'Fun With Headers
      If Obj_WDoc.ActiveWindow.View.SplitSpecial <> wdPaneNone Then
          Obj_WDoc.ActiveWindow.Panes(2).Close
      End If
      Obj_WDoc.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
      'Obj_WDoc.ActiveWindow.ActivePane.Selection.Select
      With Obj_Wapp.Selection
        .MoveDown Unit:=wdLine, Count:=2
        .MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
        .MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        Rng_Basis.Cells(Int_Count, 14).Value = Obj_Wapp.Selection
        .MoveDown Unit:=wdLine, Count:=1
        .MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
        .MoveRight Unit:=wdCharacter, Count:=7, Extend:=wdExtend
        Rng_Basis.Cells(Int_Count, 15).Value = Obj_Wapp.Selection
        .MoveDown Unit:=wdLine, Count:=1
        .EndKey Unit:=wdLine
        .MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
        .MoveRight Unit:=wdCharacter, Count:=6, Extend:=wdExtend
        Rng_Basis.Cells(Int_Count, 16).Value = Obj_Wapp.Selection
      End With
      Obj_WDoc.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
      'For Each Column of Data, 1-13....
      For Pulled_Int_Count = 1 To 13
          
         
      
      'PullMe = The Column Headers (Identified Above)
          PullMe = Wks_RollUp.Cells(1, Pulled_Int_Count + 2)
          
          'I don't know, but it works
          Obj_Wapp.Selection.HomeKey Unit:=6
          
          'Find PullMe(The Column Headers) in the Word Document
          Obj_Wapp.Selection.Find.Execute PullMe
               
          'Are we talking about the Details section?
          If Pulled_Int_Count = 12 Then
              With Obj_Wapp.ActiveDocument.Content.Duplicate
                  'Find all data between the details and the comments
                  .Find.Execute Findtext:="DETAILS:" & "*" & "COMMENTS:", MatchWildcards:=True
                  'And Select it
                  .Select
              End With
          Else
              'If We aren't talking about Details, then include everything inside of only one paragraph
              Obj_Wapp.Selection.Collapse Direction:=wdCollapseEnd
              Obj_Wapp.Selection.Extend
              Obj_Wapp.Selection.Extend
              Obj_Wapp.Selection.Extend
          End If
          
          
          'Now Put it in the Excel Speadsheet!
          Rng_Basis.Cells(Int_Count, Pulled_Int_Count).Value = Obj_Wapp.Selection
                  
          'Clear the .Find variable for the RAM Conscious
          Obj_Wapp.Selection.Find.ClearFormatting
          
      'Now move on to the next item to pull from this same report
      Next Pulled_Int_Count
  
      'Now Close This document to Save RAM
      Obj_WDoc.Close
   
  'Now Move to the next report
  Next Int_Count
      
  'Now close the Word Application
  Obj_Wapp.Quit
End Sub