Hi,

Im new and  learning VBA, and need help with a macro.

I want to copy the entire lines 2,3 and 5 from all of the word 2010 documents in one directory, and paste them in to columns A, C and B respectively in one worksheet of Excel 2010. This can be in the same directory.

I have tried writing it myself by adapting a recorded macro, but am getting lost with it. Can someone please help me?

Option Explicit
'***************
Public SendDataToExcel
'variable declaration
Dim rngSel As Word.Range
Dim origSetup As Word.PageSetup
Dim wb As Excel.Workbook

'Assign the selection to its variable
Set rngSel = Selection.Range
Set origSetup = rngSel.Sections (3) . PageSetup

'Create a new workbook from the current document

Set wb + Workbook.Add(ActiveDocument.Fullname)
wb.Range.FormattedText = rngSel. FormattedText
With wb.Sections(!) . Page 


Sub DirLoop()

      Dim MyFile As String, Sep As String

      ' Sets up the variable "MyFile" to be each file in the directory
      ' This example looks for all the files that have an .docx extension.
      ' This can be changed to whatever extension is needed. Also, this
      ' macro searches the current directory. This can be changed to any
      ' directory.

      ' Test for Windows or Macintosh platform. Make the directory request.
      Sep = Application.PathSeparator

      If Sep = "\" Then
         ' Windows platform search syntax.
         MyFile = Dir(CurDir() & Sep & "*.docx")

      Else

         ' Macintosh platform search syntax.
         MyFile = Dir("", MacID("XLS5"))
      End If

      ' Starts the loop, which will continue until there are no more files
      ' found.

      Do While MyFile <> ""

         ' Displays a message box with the name of the file. This can be
         ' changed to any procedure that would be needed to run on every
         ' file in the directory such as opening each file.

         MsgBox CurDir() & Sep & MyFile
         MyFile = Dir()
      Loop

   End Sub

Sub Copy2()
'
' Copy2 Macro
'
'
    Selection.Copy
    Set oRngDCopy = ActiveDocument.Bookmarks("\Line1").Range
    Selection.PasteAndFormat (wdFormatOriginalFormatting)
End Sub
Sub Copy1()
'
' Copy1 Macro
'
'
    Selection.MoveUp Unit:=wdLine, Count:=1
    Selection.MoveRight Unit:=wdWord, Count:=1
  Set oRngDCopy = ActiveDocument.Bookmarks("\Line2").Range
    Selection.Copy
    Selection.MoveDown Unit:=wdLine, Count:=1
    Selection.PasteAndFormat (wdFormatOriginalFormatting)
    Selection.MoveUp Unit:=wdLine, Count:=2
End Sub
Sub Copytest()
'
' Copytest Macro
'
'
    Selection.MoveDown Unit:=wdLine, Count:=1
    Selection.MoveRight Unit:=wdWord, Count:=1
    Selection.MoveLeft Unit:=wdCharacter, Count:=6
    Selection.MoveRight Unit:=wdCharacter, Count:=6, Extend:=wdExtend
    Selection.Copy
    Documents.Add DocumentType:=wdNewBlankDocument
    Selection.PasteAndFormat (wdFormatOriginalFormatting)
    Selection.TypeParagraph
    Windows("Document1").Activate
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.MoveDown Unit:=wdLine, Count:=1
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.MoveRight Unit:=wdCharacter, Count:=7, Extend:=wdExtend
    Selection.Copy
    Windows("Document2").Activate
    Windows("Document1").Activate
    Selection.PasteAndFormat (wdFormatOriginalFormatting)
    Selection.MoveDown Unit:=wdLine, Count:=2
    Selection.MoveLeft Unit:=wdCharacter, Count:=7
    Selection.MoveRight Unit:=wdCharacter, Count:=11, Extend:=wdExtend
    Selection.Copy
    Windows("Document2").Activate
    Selection.TypeParagraph
    Windows("Document1").Activate
    Selection.PasteAndFormat (wdFormatOriginalFormatting)
End Sub
Sub Testforxl()
'
' Testforxl Macro
'
'
    Selection.MoveLeft Unit:=wdCharacter, Count:=5
    Selection.MoveUp Unit:=wdLine, Count:=5
    Selection.MoveDown Unit:=wdLine, Count:=1
    Selection.MoveRight Unit:=wdCharacter, Count:=6, Extend:=wdExtend
    Selection.Copy
    Selection.MoveDown Unit:=wdLine, Count:=1
    Selection.MoveLeft Unit:=wdCharacter, Count:=6
    Selection.MoveRight Unit:=wdCharacter, Count:=7, Extend:=wdExtend
    Selection.Copy
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.MoveDown Unit:=wdLine, Count:=2
    Selection.MoveLeft Unit:=wdCharacter, Count:=7
    Selection.MoveRight Unit:=wdCharacter, Count:=11, Extend:=wdExtend
    Selection.Copy
End Sub

Hi,

After you run the code, what's the result? And I think you can set some break points to find out which code do the wrong action.

I havent run it yet because I know it wont work, and do not want to crash word.  Firstly it counts characters in line rather than copy the whole line.  I want it to loop through through the directory and copy the correct lines from each word file ( of which there are thousands) and paste it into the corresponding cell in excel.  I had to do this by hand and it took me 10 working days.  Really want to figure this out before I have to do this again :(

It definitely won't work. No offense but that code is a mess. :-)

My suggestion is before you go and try to put code together for looping through documents in a directory that you figure out exactly how the function should work with just one document open.  Here's code that should get you started.

Sub CaptureLineRange()
    Dim doc As Word.Document
    Dim rng1 As Word.Range, rng2 As Word.Range, rng3 As Word.Range
    Dim xApp As Excel.Application, xWB As Excel.Workbook, xWS As Excel.Worksheet
    Dim xRng1 As Excel.Range, xRng2 As Excel.Range, xRng3 As Excel.Range
    
    If OpenExcelWorkbook(xApp, xWB) = False Then Exit Sub
    Set xWS = xWB.Worksheets(1)
    Set xRng1 = xWS.Range("A1")
    Set xRng2 = xWS.Range("B2")
    Set xRng3 = xWS.Range("C3")
    
    Set doc = ActiveDocument
    Selection.GoTo what:=wdGoToLine, which:=wdGoToFirst, count:=1
    Set rng1 = doc.Bookmarks("\Line").Range
    Selection.GoTo what:=wdGoToLine, which:=wdGoToFirst, count:=2
    Set rng2 = doc.Bookmarks("\Line").Range
    Selection.GoTo what:=wdGoToLine, which:=wdGoToFirst, count:=3
    Set rng3 = doc.Bookmarks("\Line").Range
    
    xRng1.value = rng1.FormattedText
    xRng2.value = rng2.FormattedText
    xRng3.value = rng3.FormattedText
    
End Sub

Function OpenExcelWorkbook(ByRef xApp As Excel.Application, xWB As Excel.Workbook) As Boolean
    Dim xStart As Boolean

    On Error Resume Next
    OpenExcelWorkbook = False
    Set xApp = GetObject(Class:="Excel.Application")
    
    If xApp Is Nothing Then
        Set xApp = CreateObject(Class:="Excel.Application")
        If xApp Is Nothing Then
            MsgBox "Failed to start Excel", vbCritical
            Exit Function
        End If
        xApp.Visible = True
        xStart = True
    End If
    
    On Error GoTo ErrHandler
    Set xWB = xApp.Workbooks.Open(fileName:="H:\Test.xlsx")
    OpenExcelWorkbook = True
    Exit Function

ErrHandler:
    On Error Resume Next
    MsgBox Err.Description, vbExclamation
    If xStart And Not xApp Is Nothing Then
        xApp.Quit
    End If
    Exit Function
End Function

Many Thanks!! :)