|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
本帖最后由 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
|
|