|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
本帖最后由 182197315 于 2022-11-24 13:09 编辑
这是代码
Sub WordToExcel()
Dim DocPath As String
Dim XlsPath As String
Dim DocFile As String
Dim xlsoldFile As String
Dim xlsnewFile As String
Dim WordApp As Object
Dim WordD As Object
Set WordApp = CreateObject("Word.Application")
Dim XlsD As Workbook
Dim sDate As String, sContent As String, sReason As String
DocPath = ThisWorkbook.Path & "\1word\"
XlsPath = ThisWorkbook.Path & "\2excel\"
xlsoldFile = "修订记录表R09-01表-模板.xlsx"
DocFile = Dir(DocPath & "*.doc*")
Do While DocFile <> ""
Set WordD = WordApp.documents.Open(DocPath & DocFile)
With WordD.tables(WordD.tables.Count)
sReason = Application.Clean(.cell(2, 1).Range.Text)
sContent = Application.Clean(.cell(2, 2).Range.Text)
sDate = Application.Clean(.cell(2, 3).Range.Text)
End With
WordD.Save
WordD.Close
xlsnewFile = "修订记录表R09-01-" & Replace(DocFile, "docx", "") & ".xlsx"
FileCopy XlsPath & xlsoldFile, XlsPath & xlsnewFile
Set XlsD = Workbooks.Open(XlsPath & xlsnewFile)
With XlsD.Sheets(1)
.Range("B3") = sDate
.Range("B4") = sReason
.Range("B6") = sContent
End With
XlsD.Save
XlsD.Close
DocFile = Dir
Loop
WordApp.Quit
Set WordD = Nothing
Set WordApp = Nothing
Set XlsD = Nothing
End Sub
|
|