locked
Word Macro: Exporting Data to a LEGIBLE Excel Spreadsheet RRS feed

  • Question

  • ** Warning: I am a Newbie without programming experience **

    I am regularly sent documents like the word document here: "04172012 Results.docx".  My job is to copy and paste each line in the word doc into the linked excel spreadsheet: "04172012 Results Copied.xlsx"

    However, i KNOW there's a better way than this.  I've tried to search/replace the spaces with various characters, then saving it as a text doc, and lastly then importing it into excel, but I just can't get the right combination of characters to make it work.

    If someone can help me figure out how to get this done in such a way that I can automate, I would be very grateful.  Your help for this will save me 30-60 minutes every time i have to do it.

    I would prefer some sort of macro but being told the steps to do it manually (aside from copy and paste) would be super.

    Thanks so much!! -Jeff
    Monday, May 7, 2012 4:48 PM

Answers

  • Try this macro:

    Sub Export2XL()
        Dim app As Object
        Dim wbk As Object
        Dim wsh As Object
        Dim r As Long
        Dim p As Long
        Dim n As Long
        Dim i As Long
        Dim arr As Variant
        Dim strLine As String
        ' Start Excel
        On Error Resume Next
        Set app = GetObject(Class:="Excel.Application")
        If app Is Nothing Then
            Set app = CreateObject(Class:="Excel.Application")
            If app Is Nothing Then
                MsgBox "Can't start Excel!", vbExclamation
                Exit Sub
            End If
        End If
        On Error GoTo ErrHandler
        ' Create workbook with one worksheet
        app.ScreenUpdating = False
        Set wbk = app.Workbooks.Add(Template:=-4167) ' xlWBATWorksheet
        Set wsh = wbk.Worksheets(1)
        r = 1
        wsh.Cells(r, 1) = "PTF"
        wsh.Cells(r, 2) = "DEF"
        wsh.Cells(r, 3) = "PURCHASER"
        wsh.Cells(r, 4) = "ADDRESS"
        wsh.Cells(r, 5) = "AMOUNT"
        ' Date
        strLine = ActiveDocument.Paragraphs(1).Range.Text
        p = InStr(strLine, vbTab)
        strLine = Mid(strLine, p + 1, Len(strLine) - p)
        wsh.Name = strLine
        ' Loop
        n = ActiveDocument.Paragraphs.Count
        For i = 2 To n
            strLine = ActiveDocument.Paragraphs(i).Range.Text
            strLine = Left(strLine, Len(strLine) - 1)
            arr = Split(strLine, vbTab)
            ' Determine type
            If arr(2) = "PTF" Then
                r = r + 1
                wsh.Cells(r, 1) = arr(3)
            ElseIf arr(1) = "DEF" Then
                wsh.Cells(r, 2) = arr(2)
            ElseIf arr(1) = "COUNT" And UBound(arr) >= 3 Then
                wsh.Cells(r, 3) = arr(3)
            ElseIf arr(1) = "ADDRESS" Then
                wsh.Cells(r, 4) = arr(2)
                wsh.Cells(r, 5) = arr(4)
            Else
                ' Footer - ignore
            End If
        Next i
    ExitHandler:
        If Not app Is Nothing Then
            wsh.Range("A1:E1").EntireColumn.AutoFit
            app.ScreenUpdating = True
            app.Visible = True
        End If
        Exit Sub
    ErrHandler:
        MsgBox Err.Description, vbExclamation
        Resume ExitHandler
    End Sub

    The document with the data should be the active document when you run the macro.

    It's best to store the macro in a separate document (it must be macro-enabled, so either .doc or .docm, not .docx) or in your default document Normal.dotm.


    Regards, Hans Vogelaar

    • Marked as answer by elderlu Monday, May 7, 2012 9:28 PM
    Monday, May 7, 2012 7:58 PM

All replies

  • Try this macro:

    Sub Export2XL()
        Dim app As Object
        Dim wbk As Object
        Dim wsh As Object
        Dim r As Long
        Dim p As Long
        Dim n As Long
        Dim i As Long
        Dim arr As Variant
        Dim strLine As String
        ' Start Excel
        On Error Resume Next
        Set app = GetObject(Class:="Excel.Application")
        If app Is Nothing Then
            Set app = CreateObject(Class:="Excel.Application")
            If app Is Nothing Then
                MsgBox "Can't start Excel!", vbExclamation
                Exit Sub
            End If
        End If
        On Error GoTo ErrHandler
        ' Create workbook with one worksheet
        app.ScreenUpdating = False
        Set wbk = app.Workbooks.Add(Template:=-4167) ' xlWBATWorksheet
        Set wsh = wbk.Worksheets(1)
        r = 1
        wsh.Cells(r, 1) = "PTF"
        wsh.Cells(r, 2) = "DEF"
        wsh.Cells(r, 3) = "PURCHASER"
        wsh.Cells(r, 4) = "ADDRESS"
        wsh.Cells(r, 5) = "AMOUNT"
        ' Date
        strLine = ActiveDocument.Paragraphs(1).Range.Text
        p = InStr(strLine, vbTab)
        strLine = Mid(strLine, p + 1, Len(strLine) - p)
        wsh.Name = strLine
        ' Loop
        n = ActiveDocument.Paragraphs.Count
        For i = 2 To n
            strLine = ActiveDocument.Paragraphs(i).Range.Text
            strLine = Left(strLine, Len(strLine) - 1)
            arr = Split(strLine, vbTab)
            ' Determine type
            If arr(2) = "PTF" Then
                r = r + 1
                wsh.Cells(r, 1) = arr(3)
            ElseIf arr(1) = "DEF" Then
                wsh.Cells(r, 2) = arr(2)
            ElseIf arr(1) = "COUNT" And UBound(arr) >= 3 Then
                wsh.Cells(r, 3) = arr(3)
            ElseIf arr(1) = "ADDRESS" Then
                wsh.Cells(r, 4) = arr(2)
                wsh.Cells(r, 5) = arr(4)
            Else
                ' Footer - ignore
            End If
        Next i
    ExitHandler:
        If Not app Is Nothing Then
            wsh.Range("A1:E1").EntireColumn.AutoFit
            app.ScreenUpdating = True
            app.Visible = True
        End If
        Exit Sub
    ErrHandler:
        MsgBox Err.Description, vbExclamation
        Resume ExitHandler
    End Sub

    The document with the data should be the active document when you run the macro.

    It's best to store the macro in a separate document (it must be macro-enabled, so either .doc or .docm, not .docx) or in your default document Normal.dotm.


    Regards, Hans Vogelaar

    • Marked as answer by elderlu Monday, May 7, 2012 9:28 PM
    Monday, May 7, 2012 7:58 PM
  • WOW Hans!!! It worked flawlessly! That was very amazing and I REALLY appreciate it!
    Monday, May 7, 2012 9:28 PM
  • Would it be too much to ask if you could modify the macro to pull the data from all word docs located in specific path, instead of just the open document?  If not, this is fine and Thanks again!

    Monday, May 7, 2012 9:32 PM
  • Should the information from all those documents be copied into

    1. One and the same worksheet, or
    2. Each document into a different worksheet in the same workbook, or
    3. Each document into a worksheet in a different workbook

    Regards, Hans Vogelaar

    Monday, May 7, 2012 9:46 PM
  • Should the information from all those documents be copied into

    1. One and the same worksheet, or
    2. Each document into a different worksheet in the same workbook, or
    3. Each document into a worksheet in a different workbook

    Regards, Hans Vogelaar

    Oh, good question.  #1: One and the same document--but I think that changes my needs a little.  Could the Filename (minus the file extension) be used in an additional column to distinguish where the data from each line came from?  I can make a separate post for this request if you want.


    • Edited by elderlu Monday, May 7, 2012 9:55 PM
    Monday, May 7, 2012 9:54 PM
  • Make sure that the folder doesn't contain any other Word documents.

    The following macro will ask you to point to the folder, then process all documents in it.

    Sub Export2XL()
        Dim app As Object
        Dim wbk As Object
        Dim wsh As Object
        Dim r As Long
        Dim p As Long
        Dim n As Long
        Dim i As Long
        Dim arr As Variant
        Dim strLine As String
        Dim doc As Document
        Dim strPath As String
        Dim strFile As String
        Dim strName As String
        With Application.FileDialog(4) ' msoFileDialogFolderPicker
            If .Show Then
                strPath = .SelectedItems(1)
            Else
                MsgBox "You didn't select a folder!", vbExclamation
                Exit Sub
            End If
        End With
        If Right(strPath, 1) <> "" Then
            strPath = strPath & "\"
        End If
        ' Start Excel
        On Error Resume Next
        Set app = GetObject(Class:="Excel.Application")
        If app Is Nothing Then
            Set app = CreateObject(Class:="Excel.Application")
            If app Is Nothing Then
                MsgBox "Can't start Excel!", vbExclamation
                Exit Sub
            End If
        End If
        On Error GoTo ErrHandler
        Application.ScreenUpdating = False
        ' Create workbook with one worksheet
        app.ScreenUpdating = False
        Set wbk = app.Workbooks.Add(Template:=-4167) ' xlWBATWorksheet
        Set wsh = wbk.Worksheets(1)
        r = 1
        wsh.Cells(r, 1) = "PTF"
        wsh.Cells(r, 2) = "DEF"
        wsh.Cells(r, 3) = "PURCHASER"
        wsh.Cells(r, 4) = "ADDRESS"
        wsh.Cells(r, 5) = "AMOUNT"
        wsh.Cells(r, 6) = "FILE"
        ' Loop through Word documents
        strFile = Dir(strPath & "*.doc*")
        Do While strFile <> ""
            ' Open document
            Set doc = Documents.Open(strPath & strFile)
            p = InStrRev(strFile, ".")
            strName = Left(strFile, p - 1)
            ' Loop through document
            n = doc.Paragraphs.Count
            For i = 2 To n
                strLine = doc.Paragraphs(i).Range.Text
                strLine = Left(strLine, Len(strLine) - 1)
                arr = Split(strLine, vbTab)
                ' Determine type
                If arr(2) = "PTF" Then
                    r = r + 1
                    wsh.Cells(r, 6) = strName
                    wsh.Cells(r, 1) = arr(3)
                ElseIf arr(1) = "DEF" Then
                    wsh.Cells(r, 2) = arr(2)
                ElseIf arr(1) = "COUNT" And UBound(arr) >= 3 Then
                    wsh.Cells(r, 3) = arr(3)
                ElseIf arr(1) = "ADDRESS" Then
                    wsh.Cells(r, 4) = arr(2)
                    wsh.Cells(r, 5) = arr(4)
                Else
                    ' Footer - ignore
                End If
            Next i
            ' Close document
            doc.Close SaveChanges:=False
            ' On to the next document
            strFile = Dir
        Loop
    ExitHandler:
        If Not app Is Nothing Then
            wsh.Range("A1:F1").EntireColumn.AutoFit
            app.ScreenUpdating = True
            app.Visible = True
        End If
        Application.ScreenUpdating = True
        Exit Sub
    ErrHandler:
        MsgBox Err.Description, vbExclamation
        Resume ExitHandler
    End Sub


    Regards, Hans Vogelaar

    Monday, May 7, 2012 10:24 PM
  • For cross-posting etiquette, please read: http://www.excelguru.ca/content.php?184

    Cheers
    Paul Edstein
    [MS MVP - Word]

    Tuesday, May 8, 2012 12:47 AM
  • Hans,

    There were a couple of documents with extra data in them that the example I had didn't have and it gave me a "Subscript out of range" but there's no way you could have planned for those.  After deleting those lines it worked flawlessly.

    Thanks so much!  you have made my day.

    Tuesday, May 8, 2012 3:26 PM
  • Hans,

    I tried but couldn't figure out how to add the "Case Number" for each record to the macro.  Is that an easy fix?

    Friday, May 18, 2012 4:18 PM
  • What is the case number? And where should it be placed in the worksheet?

    Regards, Hans Vogelaar

    Friday, May 18, 2012 4:55 PM
  • What is the case number? And where should it be placed in the worksheet?

    Regards, Hans Vogelaar

    The case number in the example linked to my original post, is located in the first column of each new property.  An example would be "08CI05330" or "08CI06425".

    It should be placed in the very first column on the spreadsheet.

    Thanks again!

    Tuesday, May 29, 2012 2:44 PM
  • I had all but forgotten about this thread...

    Change the part that writes the column headers to

        wsh.Cells(r, 1) = "Case Number"
        wsh.Cells(r, 2) = "PTF"
        wsh.Cells(r, 3) = "DEF"
        wsh.Cells(r, 4) = "PURCHASER"
        wsh.Cells(r, 5) = "ADDRESS"
        wsh.Cells(r, 6) = "AMOUNT"
        wsh.Cells(r, 7) = "FILE"

    The first line is new, in the others the column number has been increased by 1.

    Change the part that writes the data to

                ' Determine type
                If arr(2) = "PTF" Then
                    r = r + 1
                    wsh.Cells(r, 7) = strName
                    wsh.Cells(r, 1) = arr(1)
                    wsh.Cells(r, 2) = arr(3)
                ElseIf arr(1) = "DEF" Then
                    wsh.Cells(r, 3) = arr(2)
                ElseIf arr(1) = "COUNT" And UBound(arr) >= 3 Then
                    wsh.Cells(r, 4) = arr(3)
                ElseIf arr(1) = "ADDRESS" Then
                    wsh.Cells(r, 5) = arr(2)
                    wsh.Cells(r, 6) = arr(4)
                Else
                    ' Footer - ignore
                End If

    The line wsh.Cells(r, 1) = arr(1) is new; the column number in the rest has been increased by 1.

    Regards, Hans Vogelaar

    Tuesday, May 29, 2012 3:49 PM
  • Perfect! woohoo! hours and hours saved. thanks again.
    Tuesday, May 29, 2012 5:42 PM
  • Hi. I am trying to do the same thing but I do not know how to reference the actual doc that the data is being imported from. Where do you put the file path?
    Wednesday, May 30, 2012 2:18 AM
  • The code in this thread is intended to be run from within Word.

    In the first reply that is marked as an answer, the document containing the data must already be open, and it must be the active document when the macro is started.

    Later on, the original poster asked how to process all documents in a folder. In the second reply marked as an answer, the macro asks the user to point at a folder, and it uses that folder. The variable strPath contains the path to the folder.


    Regards, Hans Vogelaar

    Wednesday, May 30, 2012 5:18 AM
  • Alright, I did what you said. I keep getting an error sying "subscript out of range." Basically I need  document list to export data to look like  excel sample

    I think what makes it more complicated is that some records don't have all the fields completed. I'm sorry for using your time. I really do appreciate any help. I'm not really a programmer at all. This is an assignment I have.

    Sub Update()
        Dim app As Object
        Dim wbk As Object
        Dim wsh As Object
        Dim r As Long
        Dim p As Long
        Dim n As Long
        Dim i As Long
        Dim arr As Variant
        Dim strLine As String
        ' Start Excel
        On Error Resume Next
        Set app = GetObject(Class:="Excel.Application")
        If app Is Nothing Then
            Set app = CreateObject(Class:="Excel.Application")
            If app Is Nothing Then
                MsgBox "Can't start Excel!", vbExclamation
                Exit Sub
            End If
        End If
        On Error GoTo ErrHandler
        ' Create workbook with one worksheet
        app.ScreenUpdating = False
        Set wbk = app.Workbooks.Add(Template:=-4167) ' xlWBATWorksheet
        Set wsh = wbk.Worksheets(1)
        r = 1
        wsh.Cells(r, 1) = "Name"
        wsh.Cells(r, 2) = "Address"
        wsh.Cells(r, 3) = "City"
        wsh.Cells(r, 4) = "State"
        wsh.Cells(r, 5) = "ZIP"
        wsh.Cells(r, 6) = "Country"
        wsh.Cells(r, 7) = "Phone"
        wsh.Cells(r, 8) = "Email"
        wsh.Cells(r, 9) = "Position"
        wsh.Cells(r, 10) = "1st EMAIL"
        ' Date
        strLine = ActiveDocument.Paragraphs(1).Range.Text
        p = InStr(strLine, vbTab)
        strLine = Mid(strLine, p + 1, Len(strLine) - p)
        wsh.Name = strLine
        ' Loop
        n = ActiveDocument.Paragraphs.Count
        For i = 2 To n
            strLine = ActiveDocument.Paragraphs(i).Range.Text
            strLine = Left(strLine, Len(strLine) - 1)
            arr = Split(strLine, vbTab)
            ' Determine type
            If arr(2) = "Database," Then
                r = r + 1
                wsh.Cells(r, 1) = arr(3)
            ElseIf arr(1) = "Offices located in San Diego CA" Then
                wsh.Cells(r, 2) = arr(2)
            ElseIf arr(1) = "COUNT" And UBound(arr) >= 3 Then
                wsh.Cells(r, 3) = arr(3)
            ElseIf arr(1) = "ADDRESS" Then
                wsh.Cells(r, 4) = arr(2)
                wsh.Cells(r, 5) = arr(4)
            Else
                ' Footer - ignore
            End If
        Next i
    ExitHandler:
        If Not app Is Nothing Then
            wsh.Range("A1:J1").EntireColumn.AutoFit
            app.ScreenUpdating = True
            app.Visible = True
        End If
        Exit Sub
    ErrHandler:
        MsgBox Err.Description, vbExclamation
        Resume ExitHandler
    End Sub
    • Edited by Katamari13 Wednesday, May 30, 2012 3:06 PM
    Wednesday, May 30, 2012 3:05 PM
  • It's not clear how the data in the Word document should map to the columns in the worksheet. The data in the worksheet look completely different from those in the Word document...

    Regards, Hans Vogelaar

    Wednesday, May 30, 2012 3:40 PM
  • So I am expected to process hundreds of these into excel. What would be the fastest way? Should I convert the .doc into a text file, replace some characters and import it into excel?
    Wednesday, May 30, 2012 4:51 PM
  • Once we know how to convert one document, it's easy to write a macro to convert hundreds of documents. But currently, we don't even know how to convert one document. Let's take the first part of the document:

    ----

    1 of 205 DOCUMENTS
    Copyright 2011 NetProspex, Inc.,  ,Contacts Database,  Jahan  Jamshidi,CAREER: ,San Diego State University; Director; Director; jjamshidi@aztecshops.com; (619) 594-7585
    SAN DIEGO STATE UNIVERSITY, San Diego, United States, CA, 92182-1701; $250M to less than $1B;
    LOAD-DATE:  

    ----

    Can you explain in detail which part of the text should be copied to which of the 10 columns in the Excel worksheet?


    Regards, Hans Vogelaar

    Wednesday, May 30, 2012 6:51 PM