Copy Drop Down Form Fields from Word onto Excel

Hello there, i have a macro that copies content from Word and organizes them in Excel. The macro copies the text in the shaded cell in the Word file, and then it copies the text in the cell beside it to the right. My problem is that it can't copy the displayed text in a Drop Down Form Field, some of which are in the cells that are beside the shaded cells. I tried to implement this code:

Dim strText As String
Dim ix As Integer

ix = objDoc.FormFields("Dropdown1").DropDown.Value
strText = objDoc.FormFields("Dropdown1").DropDown.ListEntries(ix).Name

Open in new window


On to the macro:
Option Explicit

Sub WordToExcel()

    Dim sh As Excel.Worksheet
    Dim strFolder As String
    Dim strFile As String
    Dim strFullName As String
    Dim r As Integer
    
    Set sh = ThisWorkbook.Worksheets("Sheet1")
    'Insert Folder Link
    strFolder = "C:\MyFolder\"
    strFile = Dir(strFolder & "*.doc*")
    r = 2
    Do Until strFile = ""
        strFullName = strFolder & strFile
        CopyTableFromDocx strFullName, sh, r
        strFile = Dir()
        r = r + 1
    Loop

End Sub

Sub CopyTableFromDocx(strMSWordFileName As String, sh As Worksheet, r As Integer)

    Dim objDoc As Word.Document
    'Dim lngTableIndex As Long
    Dim objWordTable As Word.Table
    Dim objWordCell As Word.cell
    Dim strLabel As String
    Dim strData As String
    Const mtrDsc As String = "? "
    Dim c As Integer
    Dim t As Integer
    Dim bFound As Boolean
    'Dim lngRowIndex As Long, lngColumnIndex As Long
    'Dim strCleanCellValue As String

    On Error GoTo CleanUp

    'get reference to word doc
    Set objDoc = GetObject(strMSWordFileName)

    objDoc.Application.Visible = True
    
    t = 0
    
    For Each objWordTable In objDoc.Tables 'step through tables
        t = t + 1
        'iterate cells
        For Each objWordCell In objWordTable.Range.Cells
            Select Case GetCellText(objWordCell)
                Case "Type:", "Category:", "Name:", "AlternateName:", "ID:", "Class:", "Width:", "Text:", "Text-Align:", "Border-Radius:", "Margin:"
                
                strLabel = UCase(Trim(GetCellText(objWordCell)))
        
                c = 1
                bFound = False
                Do Until sh.Cells(1, c).Value = ""
                    If sh.Cells(1, c).Value = strLabel Then
                        bFound = True
                        Exit Do
                    End If
                    c = c + 1
                Loop
                If Not bFound Then
                    sh.Cells(1, c).Value = strLabel
                End If
                strData = Trim(GetCellText(objWordTable.cell(objWordCell.RowIndex, objWordCell.ColumnIndex + 1)))
                sh.Cells(r, c).Value = strData
                
            End Select 'shaded cell?
        Next objWordCell
        
        'success
        Debug.Print "Successfully copied table # " & t & " from " & strMSWordFileName
    Next objWordTable
    objDoc.Close
CleanUp:
    If Err.Number <> 0 Then
        Debug.Print Err.Number & " " & Err.Description
        Err.Clear
    End If

End Sub

Function GetCellText(cl As Word.cell) As String
    Dim rng As Word.Range
    
    Set rng = cl.Range
    rng.MoveEnd wdCharacter, -1
    GetCellText = rng.Text
    
End Function

Open in new window


I was thinking of putting an if statement in the For Each loop, but i receive an error. Could anyone help me out?

This is the Word File:

This is what its supposed to look like once it done running. (This is without the text that is beside the shaded cell)
rilAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

LET (Learn Excel in Tamil)Reporting Automation ExpertCommented:
Hi Ril,

Good day,

Kindly find attached macro file for your reference, i am not expert in Word macro, hence i have created excel based macro to fulfill your requirement, please check and let me know

Sub wrdtoexcel()

Application.DisplayAlerts = False
Dim wrdapp As Word.Application
Dim wrdoc As Word.Document
Set wrdapp = CreateObject("Word.Application")
wrdapp.Visible = True
Set wrddoc = wrdapp.Documents.Open("C:\test\Table-Example2.docx")

Range("A2").Select
With wrdapp
    
    .Selection.MoveRight Unit:=wdCharacter, Count:=8
    .Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
    .Selection.Copy
     ActiveCell.PasteSpecial xlPasteValues 'Number:
    .Selection.MoveDown Unit:=wdLine, Count:=5
    .Selection.MoveRight Unit:=wdCell
    .Selection.Copy
     ActiveCell.Offset(0, 1).PasteSpecial xlPasteValues 'Type:
     
    .Selection.MoveDown Unit:=wdLine, Count:=1
    .Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
    .Selection.Copy
    ActiveCell.Offset(0, 1).PasteSpecial xlPasteValues 'Category:
    
    .Selection.MoveDown Unit:=wdLine, Count:=2
    .Selection.MoveLeft Unit:=wdCell
    .Selection.MoveLeft Unit:=wdCell
    .Selection.Copy
    ActiveCell.Offset(0, 1).PasteSpecial xlPasteValues 'Name:

    .Selection.MoveRight Unit:=wdCell
    .Selection.MoveRight Unit:=wdCell
    .Selection.Copy
    ActiveCell.Offset(0, 1).PasteSpecial xlPasteValues 'AlternateName:

     .Selection.MoveRight Unit:=wdCell
    .Selection.MoveRight Unit:=wdCell
    .Selection.Copy
    ActiveCell.Offset(0, 1).PasteSpecial xlPasteValues 'ID:

    .Selection.MoveRight Unit:=wdCell
    .Selection.MoveRight Unit:=wdCell
    .Selection.Copy
    ActiveCell.Offset(0, 1).PasteSpecial xlPasteValues  'Class:

    .Selection.MoveRight Unit:=wdCell
    .Selection.MoveRight Unit:=wdCell
    .Selection.Copy
    ActiveCell.Offset(0, 1).PasteSpecial xlPasteValues ' Width:

    .Selection.MoveDown Unit:=wdLine, Count:=17
    .Selection.MoveUp Unit:=wdLine, Count:=1
    .Selection.MoveRight Unit:=wdCell
    .Selection.Copy
     ActiveCell.Offset(0, 1).PasteSpecial xlPasteValues  ' Text:


    .Selection.MoveRight Unit:=wdCell
    .Selection.MoveRight Unit:=wdCell
    .Selection.Copy
    ActiveCell.Offset(0, 1).PasteSpecial xlPasteValues 'Text-Align:

    .Selection.MoveRight Unit:=wdCell
    .Selection.MoveRight Unit:=wdCell
    .Selection.Copy
    ActiveCell.Offset(0, 1).PasteSpecial xlPasteValues 'Border-Radius:

    .Selection.MoveRight Unit:=wdCell
    .Selection.MoveRight Unit:=wdCell
    .Selection.Copy
      ActiveCell.Offset(0, 1).PasteSpecial xlPasteValues 'Margin:
      
      ActiveCell.Offset(1, -11).Select
     
.ActiveDocument.Close Savechanges = False


Set wrdapp = Nothing
Set wrddoc = Nothing
End With
End Sub

Open in new window

Copy-Drop-Down-Form-Fields-from-Wor.xlsm
0
rilAuthor Commented:
Hi There,

Thanks for commenting, but is there a way to for your macro to do that for a number of files? And to also pick the text to be selected as a table title (text with grey background in Excel)? I just want to know how to implement those two codes that i posted above.
0
NorieVBA ExpertCommented:
You can get the value from a form field using the Result property and you can check if a range has a FormField in it using it's FormFields.Count property.

If you combine those two you could adjust the GetCellText function to this so it retrieves the values from the formfields.
Function GetCellText(cl As Word.cell) As String
Dim rng As Word.Range

    Set rng = cl.Range
    If rng.FormFields.Count = 1 Then
        GetCellText = rng.FormFields(1).Result
    Else
        rng.MoveEnd wdCharacter, -1
        GetCellText = rng.Text
    End If
    
End Function

Open in new window

0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

rilAuthor Commented:
What if there were 2 form fields in one cell?

And by the way, Thank you so much Norie!
0
NorieVBA ExpertCommented:
Well, If that was the case I suppose one way to deal with it would be to loop through all the form fields, get the value from each and then do whatever you need to do with them.

For example, if you wanted to concatenate all the form fields in a cell and return that as the cell text you could use something like this.
Function GetCellText(cl As Word.cell) As String
Dim rng As Word.Range
Dim I As Long
Dim arrData()

    Set rng = cl.Range

    If rng.FormFields.Count >0 1 Then
        ReDim arrData(1 To rng.FormFields.Count)
        For I = 1 To rng.FormFields.Count
            arrData = rng.FormFields(I).Result
        Next I
        GetCellText = Join(arrData, " ")
    Else
        rng.MoveEnd wdCharacter, -1
        GetCellText = rng.Text
    End If
    
End Function

Open in new window

0
GrahamSkanRetiredCommented:
I have rewritten the whole thing in the light of your new requirements. The original found columns labels from the Word  document and set the names from the found text. You have now hard-coded that text in the Case statement and preloaded the headers in the worksheet.

Option Explicit


Sub WordToExcel()

    Dim sh As Excel.Worksheet
    Dim strFolder As String
    Dim strFile As String
    Dim strFullName As String
    Dim r As Integer 'worksheet row counter
    
    Set sh = ThisWorkbook.Worksheets("Sheet1")
    'Insert Folder Link
    strFolder = "C:\MyFolder\"
    strFile = Dir(strFolder & "*.doc*")
    
    r = 2
    'get the names of all the Word files in the folder and call CopyTableFromDocx for each one
    Do Until strFile = ""
        strFullName = strFolder & strFile
        CopyTableFromDocx strFullName, sh, r
        strFile = Dir()
        r = r + 1
    Loop

End Sub

Sub CopyTableFromDocx(strMSWordFileName As String, sh As Worksheet, r As Integer)

    Dim objDoc As Word.Document
    Dim objWordTable As Word.Table
    Dim objWordCell As Word.cell
    Dim objWdDataCell As Word.cell
    Dim strLabel As String
    Dim strData As String
    Dim c As Integer 'worksheet column counter
    Dim t As Integer 'table counter. only used in Debug.Print
    Dim bFound As Boolean 'flag to show column header found
    Dim ix As Integer 'index in dropdown list
    Dim ffld As Word.FormField
    
    On Error GoTo CleanUp

    'get reference to word doc
    Set objDoc = GetObject(strMSWordFileName)

    objDoc.Application.Visible = True
    
    t = 0
    
    For Each objWordTable In objDoc.Tables 'step through tables
        t = t + 1
        'iterate through Word table cells
        For Each objWordCell In objWordTable.Range.Cells
            strLabel = Trim(GetCellText(objWordCell))
            'Debug.Print strLabel
            Select Case strLabel
                Case "Type:", "Category:", "Name:", "AlternateName:", "ID:", "Class:", "Width:", "Text:", "Text-Align:", "Border-Radius:", "Margin:"
                
                    'look for the column heading in worksheet
                    c = 1 'column counter
                    bFound = False
                    'find column with heading to match label text
                    Do Until sh.Cells(1, c).Value = ""
                        If StrComp(sh.Cells(1, c).Value, strLabel, vbTextCompare) = 0 Then  'compare ignoring capitalisation
                            bFound = True
                            Exit Do
                        End If
                        c = c + 1
                    Loop
                    
                    If bFound Then
                        'get the data text
                        Set objWdDataCell = objWordCell.Next 'data cell follows label cell
                        If objWdDataCell.Range.FormFields.Count > 0 Then
                            Set ffld = objWdDataCell.Range.FormFields(1)
                            If ffld.Type = wdFieldFormDropDown Then
                                ix = ffld.DropDown.Value
                                strData = ffld.DropDown.ListEntries(ix).Name
                            End If
                        Else
                            'no formfield, so just get the text
                            strData = Trim(GetCellText(objWdDataCell))
                        End If
                        
                        sh.Cells(r, c).Value = strData
                    Else
                        MsgBox "Column heading '" & strLabel & "' not found in worksheet"
                    End If
                Case Else
                    'do nothing: not a label cell
            End Select
        Next objWordCell
        
        'success
        'Debug.Print "Successfully copied table # " & t & " from " & strMSWordFileName
    Next objWordTable
ExitSub:
    objDoc.Close
    On Error GoTo 0 'disable special error handling
    Exit Sub
CleanUp:
    If Err.Number <> 0 Then
        Debug.Print Err.Number & " " & Err.Description
        Resume ExitSub
    End If

End Sub

Function GetCellText(cl As Word.cell) As String
    Dim rng As Word.Range
    
    Set rng = cl.Range
    rng.MoveEnd wdCharacter, -1
    GetCellText = rng.Text
    
End Function

Open in new window

0
GrahamSkanRetiredCommented:
Re form fields.
After design, the document should be protected for filling in forms. This means that text that is not in a form field cannot be changed.

You haven't said what you want to happen in the case of multiple form field in a Word table cell. As written the code will ignore all but the first form field and any that are not dropdowns.

If you don't have to support Word versions earlier than 2007, you are better advised to use content controls. Since 2007 other types on control (ActiveX and formfields) have been deprecated.
0
rilAuthor Commented:
Hi Norie,

The macro receives a compile error saying that i can't assign rng.FormFields(I).Result to the array arrData
0
NorieVBA ExpertCommented:
ril

The code I posted for handling multiple form fields was untested and written on the fly, I think there was a typo in it.

Here it is with the typo fixed.
Function GetCellText(cl As Word.cell) As String
Dim rng As Word.Range
Dim I As Long
Dim arrData()

    Set rng = cl.Range

    If rng.FormFields.Count >0 1 Then
        ReDim arrData(1 To rng.FormFields.Count)
        For I = 1 To rng.FormFields.Count
            arrData(I) = rng.FormFields(I).Result
        Next I
        GetCellText = Join(arrData, " ")
    Else
        rng.MoveEnd wdCharacter, -1
        GetCellText = rng.Text
    End If
    
End Function

Open in new window



P.S. Do you actually have multiple form fields in cells?
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
rilAuthor Commented:
Just in some cells, Here's the Word file Table-Example2.docx
0
rilAuthor Commented:
OK im satisfied now, i'll stop bothering you guys. Thank you so much everyone!
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Office

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.