[英]VBA Excel to Word Question: trying to transfer multiple data from the same row
[英]transfer data from word to excel via vba
我在ms word中有一个表单,其中一些字段是内容控件,而某些字段(是单选按钮)是ActiveX控件。 我想自动将数百个单词形式传输到Excel文件中。 我使用以下vba代码:
Sub getWordFormData()
Dim wdApp As New Word.Application
Dim myDoc As Word.Document
Dim CCtl As Word.ContentControl
Dim myFolder As String, strFile As String
Dim myWkSht As Worksheet, i As Long, j As Long
myFolder = "C:\Users\alarfajal\Desktop\myform"
Application.ScreenUpdating = False
If myFolder = "" Then Exit Sub
Set myWkSht = ActiveSheet
ActiveSheet.Cells.Clear
Range("A1") = "name"
Range("a1").Font.Bold = True
Range("B1") = "age"
Range("B1").Font.Bold = True
Range("C1") = "gender"
Range("C1").Font.Bold = True
Range("D1") = "checkbox1"
Range("D1").Font.Bold = True
Range("E1") = "checkbox2"
Range("E1").Font.Bold = True
Range("F1") = "singlechoice1"
Range("F1").Font.Bold = True
Range("G1") = "singlechoice2"
Range("G1").Font.Bold = True
i = myWkSht.Cells(myWkSht.Rows.Count, 1).End(xlUp).Row
strFile = Dir(myFolder & "\*.docx", vbNormal)
While strFile <> ""
i = i + 1
Set myDoc = wdApp.Documents.Open(Filename:=myFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With myDoc
j = 0
For Each CCtl In .ContentControls
j = j + 1
myWkSht.Cells(i, j) = CCtl.Range.Text
Next
myWkSht.Columns.AutoFit
End With
myDoc.Close SaveChanges:=False
strFile = Dir()
Wend
wdApp.Quit
Set myDoc = Nothing: Set wdApp = Nothing: Set myWkSht = Nothing
Application.ScreenUpdating = True
End Sub
所有数据(文本字段,复选框)均已成功传输,但是单选按钮(即ActiveX)未传输。
这是doc一词:
这是出色的结果:
我怎么解决这个问题?
您的单选按钮是inlineshapes,因此您需要一个单独的循环
为了与您当前的代码保持一致,它将类似于
Dim shp As InlineShape
For Each shp In .InlineShapes
j = j + 1
myWkSht.Cells(i, j) = shp.OLEFormat.Object.Value
Next shp
但是我不想依靠Word总是给我正确的顺序,并且可能还有其他inlineshapes,所以最好先检查一下控件:
With myDoc
'content controls
For Each CCtl In .ContentControls
Select Case CCtl.Title
Case "name"
myWkSht.Cells(i, 1) = CCtl.Range.Text
'similar for age and gender
Case "checkbox1"
myWkSht.Cells(i, 4) = CCtl.Checked 'true and false are easier to evaluate in Excel than the checkmark symbols
'same for checkbox 2
End Select
Next CCtl
'option buttons
For Each shp In .InlineShapes
If shp.Type = wdInlineShapeOLEControlObject Then 'skip other inlineshapes
Select Case shp.OLEFormat.Object.Name
Case "singleSelectQuestionOption1" 'name it something unique
myWkSht.Cells(i, 6) = shp.OLEFormat.Object.Value
'similar for option button 2
End Select
End If
Next shp
End With
您可以通过名称引用Word文档上的ActiveX控件
myDoc.singlechoice1.Value
最好通过它们的标签名称来引用ContentControls
。
myDoc.SelectContentControlsByTag(“ name”)。Item(1).Range.Text
Sub getWordFormData()
Dim wdApp As Object, myDoc As Object
Dim myFolder As String, strFile As String
Dim i As Long, j As Long
myFolder = "C:\Users\alarfajal\Desktop\myform"
If Len(Dir(myFolder)) = 0 Then
MsgBox myFolder & vbCrLf & "Not Found", vbInformation, "Cancelled - getWordFormData"
Exit Sub
End If
Application.ScreenUpdating = False
Set wdApp = CreateObject("Word.Application")
With ActiveSheet
.Cells.Clear
With .Range("A1:G1")
.Value = Array("name", "age", "gender", "checkbox1", "checkbox2", "singlechoice1", "singlechoice2")
.Font.Bold = True
End With
strFile = Dir(myFolder & "\*.docx", vbNormal)
i = 1
While strFile <> ""
i = i + 1
Set myDoc = wdApp.Documents.Open(Filename:=myFolder & "\" & strFile, ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
.Cells(i, 1).Value = myDoc.SelectContentControlsByTag("name").Item(1).Range.Text
.Cells(i, 2).Value = myDoc.SelectContentControlsByTag("age").Item(1).Range.Text
.Cells(i, 3).Value = myDoc.SelectContentControlsByTag("gender").Item(1).Range.Text
.Cells(i, 4).Value = myDoc.SelectContentControlsByTag("checkbox1").Item(1).Checked
.Cells(i, 5).Value = myDoc.SelectContentControlsByTag("checkbox2").Item(1).Checked
.Cells(i, 6).Value = myDoc.singlechoice1.Value
.Cells(i, 7).Value = myDoc.singlechoice2.Value
myDoc.Close SaveChanges:=False
strFile = Dir()
Wend
wdApp.Quit
Application.ScreenUpdating = True
End With
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.