如何将Word文本框或组合框中的数据导出到Excel中

时间：2017-08-22 12:29:31

标签： vba excel-vba word-vba excel

我尝试在word文档中创建一个宏来创建一个新的Excel工作表，填充标题并从单词doc textbox，combobox和label中提取特定数据到单元格在新创建的Excel工作表中。我能够创建excel并输入标题，但是，我没有成功从word中提取数据。我一直收到一个错误，它要求丢失一个对象。我是否需要将doc这个词作为对象？ 

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 个答案:

答案 0 :(得分：0)

我明白了。我没有打电话给＃34; ThisDocument＆＃34;尝试从文本框中检索数据时。 

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

相关问题
最新问题