Results 1 to 4 of 4
  1. #1
    New Lounger
    Join Date
    Feb 2015
    Posts
    5
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Archiving word documents in excel using VBA

    Hey everyone

    I was wondering if someone could guide me to the proper resources or help me to come up with a macro for the following:




    Basically I have columns of hyperlinks to word documents and in the adjacent column, I'd like to have the copied and pasted content of those documents in the adjacent column, shrunk to fit.

    This would immensely help me because right now I am clicking the link, Ctrl+A, Ctrl+C the word document, closing the document, then Ctrl+V-ing each and every time.

    I tried to record a macro (in excel) but it seems that the code doesn't recognize the select all/copy functions done in the word document. I've also created a shortcut macro (in Word) just to simplify the select all/copy functions under one shortcut but it doesn't save me enough time.

    What I need is for the entirety of the word document to be archived but that means all text, I don't care if diagrams, charts, formatting, or images do not carry over.


    Sub Macro4()
    '
    ' Macro4 Macro
    '
    ' Keyboard Shortcut: Ctrl+q
    '
    Range("C3").Select
    Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
    Range("D3").Select
    ActiveCell.FormulaR1C1 = _
    "ARTICLE TEXT......."
    "ARTICLE TEXT......."
    "ARTICLE TEXT......."
    "ARTICLE TEXT......."
    "ARTICLE TEXT......."
    "ARTICLE TEXT......."
    "ARTICLE TEXT......."
    Range("D3").Select
    With Selection
    .HorizontalAlignment = xlGeneral
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = True
    .ReadingOrder = xlContext
    .MergeCells = False
    End With
    End Sub

    This is what I get, how can I get the macro to detect my select all/copy functions in the word document before pasting it into the adjacent cell in excel?

  2. #2
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,436
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    Shenqila,

    This is roughly what you want I think but I can't get the selection of the whole document statement to work. Maybe, someone with more familiarity with Word can fix it.

    Code:
    Option Explicit
    
    Sub EmbedHLDocs()
    
       Dim oWordApp       As New Word.Application  'Use this for Early Binding
       
       Dim zFileName  As String
       Dim objWordDoc As Object
       
    '*** Address should return the the file spec but in some cases it returns ..\..\restof spec.
    '*** and this does not resolve properly! using .Name works if the filespec is the name!
       zFileName = ActiveCell.Offset(0, -1).Hyperlinks.Item(1).Address
       Debug.Print zFileName
       
        GoTo WordDoc
       
    TrapWordError:
    
        If Err = 462 Then
          MsgBox "Microsoft Word OLE did NOT initiate properly!" & vbCrLf & _
                 "Please use Ctrl+Alt+Del and use the End Task button" & vbCrLf & _
                 "to close all occurances of WinWord." & vbCrLf & _
                 "Then restart this macro." & vbCrLf & _
                 Str(Err) & ": " & Error(Err), vbOKOnly + vbCritical, _
                 "Object Linking & Embedding Error"
        Else
          MsgBox "An unknown error has occured, please report the following" & _
                 vbCrLf & "to the system developer:" & _
                 vbCrLf & Str(Err) & ": " & Error(Err), vbCritical, _
                 "Untrapped Error"
        End If
       
        Exit Sub
        
    WordDoc:
       On Error GoTo TrapWordError   'Turn error trap ON
        
       With oWordApp
       
           .Documents.Open Filename:=zFileName, ReadOnly:=True, Visible:=True
           
           With ActiveDocument
               
               .Selection.EndKey Unit:=wdStory, Extend:=wdExtend '*** Causes Error?
               .Selection.Copy
               ActiveSheet.Paste
               Application.CutCopyMode = False
               
               .Close
           End With  'ActiveDocument
           
       End With 'oWordApp
       
       oWordApp.Quit
       Set oWordApp = Nothing
            
    End Sub
    Note: The code uses early binding and thus requires a reference to Word to be set in the VBE.

    HTH
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  3. #3
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,436
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    Shenqila,

    This is roughly what you want I think but I can't get the selection of the whole document statement to work. Maybe, someone with more familiarity with Word can fix it.

    Code:
    Option Explicit
    
    Sub EmbedHLDocs()
    
       Dim oWordApp       As New Word.Application  'Use this for Early Binding
       
       Dim zFileName  As String
       Dim objWordDoc As Object
       
    '*** Address should return the the file spec but in some cases it returns ..\..\restof spec.
    '*** and this does not resolve properly! using .Name works if the filespec is the name!
       zFileName = ActiveCell.Offset(0, -1).Hyperlinks.Item(1).Address
       Debug.Print zFileName
       
        GoTo WordDoc
       
    TrapWordError:
    
        If Err = 462 Then
          MsgBox "Microsoft Word OLE did NOT initiate properly!" & vbCrLf & _
                 "Please use Ctrl+Alt+Del and use the End Task button" & vbCrLf & _
                 "to close all occurances of WinWord." & vbCrLf & _
                 "Then restart this macro." & vbCrLf & _
                 Str(Err) & ": " & Error(Err), vbOKOnly + vbCritical, _
                 "Object Linking & Embedding Error"
        Else
          MsgBox "An unknown error has occured, please report the following" & _
                 vbCrLf & "to the system developer:" & _
                 vbCrLf & Str(Err) & ": " & Error(Err), vbCritical, _
                 "Untrapped Error"
        End If
       
        Exit Sub
        
    WordDoc:
       On Error GoTo TrapWordError   'Turn error trap ON
        
       With oWordApp
       
           .Documents.Open Filename:=zFileName, ReadOnly:=True, Visible:=True
           
           With ActiveDocument
               
               .Selection.EndKey Unit:=wdStory, Extend:=wdExtend '*** Causes Error?
               .Selection.Copy
               ActiveSheet.Paste
               Application.CutCopyMode = False
               
               .Close
           End With  'ActiveDocument
           
       End With 'oWordApp
       
       oWordApp.Quit
       Set oWordApp = Nothing
            
    End Sub
    Note: The code uses early binding and thus requires a reference to Word to be set in the VBE.

    HTH
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  4. #4
    New Lounger
    Join Date
    Feb 2015
    Posts
    5
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Thank you so much, RetiredGeek!

    I'll study your code and see what I can do with it.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •