How to export data from Word textbox or combobox into excel

0
votes

I'm trying to create a macro in my word document to create a new excel worksheet, populate the headers and extract specific data from the word doc textbox's, combobox's and labels to cells in the newly created excel worksheet. I am able to create the excel and input the headers, however, I am unsuccessful in pulling ins the data from word. I keep getting an error, which calls for a missing object. do I need to dim the word doc as object? 

Sub ExcelCreate()

Dim objExcel As Excel.Application
Dim objDoc As Excel.Workbook

Set objExcel = CreateObject("Excel.Application")
Set objDoc = objExcel.Workbooks.Add

objExcel.Visible = True

objExcel.ScreenUpdating = False

objDoc.Worksheets(1).Cells(1, 1).Value = "QDR #"
objDoc.Worksheets(1).Cells(1, 2).Value = "Inspector #"
objDoc.Worksheets(1).Cells(1, 3).Value = "Area where defect was discovered"
objDoc.Worksheets(1).Cells(1, 4).Value = "Value Stream Origination"
objDoc.Worksheets(1).Cells(1, 5).Value = "Part Number"
objDoc.Worksheets(1).Cells(1, 6).Value = "Part Description"
objDoc.Worksheets(1).Cells(1, 7).Value = "Qty"
objDoc.Worksheets(1).Cells(1, 8).Value = "Date"
objDoc.Worksheets(1).Cells(1, 9).Value = "Order Number"
objDoc.Worksheets(1).Cells(1, 10).Value = "Parts Order"
objDoc.Worksheets(1).Cells(1, 11).Value = "Machine #"
objDoc.Worksheets(1).Cells(1, 12).Value = "Root Cause Analysis"
objDoc.Worksheets(1).Cells(1, 13).Value = "Corrective Action"
objDoc.Worksheets(1).Cells(1, 14).Value = "Defect Description"
objDoc.Worksheets(1).Cells(1, 15).Value = "Defect Category"
objDoc.Worksheets(1).Cells(1, 16).Value = "Defect Code"
objDoc.Worksheets(1).Cells(1, 17).Value = "Blank"
objDoc.Worksheets(1).Cells(1, 18).Value = "Disposition"
objDoc.Worksheets(1).Cells(1, 19).Value = "Blank"
objDoc.Worksheets(1).Cells(1, 20).Value = "Scrap Code"
objDoc.Worksheets(1).Cells(1, 21).Value = "Vendor / Supplier Name"

objDoc.Worksheets(1).Cells(2, 1).Value = TextBox22.Value
objDoc.Worksheets(1).Cells(2, 2).Value = ComboBox3.Value
objDoc.Worksheets(1).Cells(2, 3).Value = ComboBox2.Value

Dim objWsht As Excel.Worksheet

Set objWsht = objDoc.Worksheets(1)
objExcel.ScreenUpdating = True
objWsht.Range(objWsht.Cells(1, 1), objWsht.Cells(1, 21)).Select
objWsht.Range(objWsht.Cells(2, 1), objWsht.Cells(2, 3)).Select
objExcel.ScreenUpdating = False

With objExcel.Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .ThemeColor = xlThemeColorDark1
    .TintAndShade = -0.2
    .PatternTintAndShade = 0
End With

objExcel.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
objExcel.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
objExcel.Selection.Borders(xlEdgeLeft).LineStyle = xlNone

With objExcel.Selection.Borders(xlEdgeTop)
    .LineStyle = xlDouble
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThick
End With

With objExcel.Selection.Borders(xlEdgeBottom)
    .LineStyle = xlDouble
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThick
End With
objExcel.Selection.Borders(xlEdgeRight).LineStyle = xlNone
objExcel.Selection.Borders(xlInsideVertical).LineStyle = xlNone
objExcel.Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

objExcel.ScreenUpdating = True

End Sub

1
vbaexcelms-word

1 Answers

0
votes

I figured it out. I did not call "ThisDocument" when trying to retrieve the data from the textboxes. 

Sub ExcelCreate()

Dim objExcel As Excel.Application
Dim objDoc As Excel.Workbook

Set objExcel = CreateObject("Excel.Application")
Set objDoc = objExcel.Workbooks.Add

objExcel.Visible = True

objExcel.ScreenUpdating = False

objDoc.Worksheets(1).Cells(1, 1).Value = "QDR #"
objDoc.Worksheets(1).Cells(1, 2).Value = "Inspector #"
objDoc.Worksheets(1).Cells(1, 3).Value = "Area where defect was discovered"
objDoc.Worksheets(1).Cells(1, 4).Value = "Value Stream Origination"
objDoc.Worksheets(1).Cells(1, 5).Value = "Part Number"
objDoc.Worksheets(1).Cells(1, 6).Value = "Part Description"
objDoc.Worksheets(1).Cells(1, 7).Value = "Qty"
objDoc.Worksheets(1).Cells(1, 8).Value = "Date"
objDoc.Worksheets(1).Cells(1, 9).Value = "Order Number"
objDoc.Worksheets(1).Cells(1, 10).Value = "Parts Order"
objDoc.Worksheets(1).Cells(1, 11).Value = "Machine #"
objDoc.Worksheets(1).Cells(1, 12).Value = "Root Cause Analysis"
objDoc.Worksheets(1).Cells(1, 13).Value = "Corrective Action"
objDoc.Worksheets(1).Cells(1, 14).Value = "Defect Description"
objDoc.Worksheets(1).Cells(1, 15).Value = "Defect Category"
objDoc.Worksheets(1).Cells(1, 16).Value = "Defect Code"
objDoc.Worksheets(1).Cells(1, 17).Value = "Blank"
objDoc.Worksheets(1).Cells(1, 18).Value = "Disposition"
objDoc.Worksheets(1).Cells(1, 19).Value = "Blank"
objDoc.Worksheets(1).Cells(1, 20).Value = "Scrap Code"
objDoc.Worksheets(1).Cells(1, 21).Value = "Vendor / Supplier Name"


Dim objWsht As Excel.Worksheet

Set objWsht = objDoc.Worksheets(1)
objExcel.ScreenUpdating = True

'My additions
objDoc.Worksheets(1).Cells(2, 1).Value = ThisDocument.TextBox21.Text
objDoc.Worksheets(1).Cells(2, 2).Value = ThisDocument.ComboBox3.Text
objDoc.Worksheets(1).Cells(2, 3).Value = ThisDocument.ComboBox2.Text

objWsht.Range(objWsht.Cells(1, 1), objWsht.Cells(1, 21)).Select
objExcel.ScreenUpdating = False

With objExcel.Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .ThemeColor = xlThemeColorDark1
    .TintAndShade = -0.2
    .PatternTintAndShade = 0
End With

objExcel.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
objExcel.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
objExcel.Selection.Borders(xlEdgeLeft).LineStyle = xlNone

With objExcel.Selection.Borders(xlEdgeTop)
    .LineStyle = xlDouble
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThick
End With

With objExcel.Selection.Borders(xlEdgeBottom)
    .LineStyle = xlDouble
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThick
End With
objExcel.Selection.Borders(xlEdgeRight).LineStyle = xlNone
objExcel.Selection.Borders(xlInsideVertical).LineStyle = xlNone
objExcel.Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

objExcel.ScreenUpdating = True

End Sub