如何使用VBmacros将数据从Word表格复制到Excel表格时保留源格式？

我试图从Word表中复制一些数据到一个Excel表格使用VBmacros。

它根据需要完美地复制文本。

现在我想保留Word文档中的源格式。

我想保存的东西是

1. 通过
2. 颜色
3. 子弹
4. 新的字符

我正在使用下面的代码来复制 –

objTemplateSheetExcelSheet.Cells(1, 2) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)

请让我知道如何编辑这个以保持源格式。

我使用的逻辑如下 –

 wdFileName = Application.GetOpenFilename("Word files (*.*),*.*", , _ "Browse for file containing table to be imported") '(Browsing for a file) If wdFileName = False Then Exit Sub '(user cancelled import file browser) Set wdDoc = GetObject(wdFileName) '(open Word file) With wdDoc 'enter code here` TableNo = wdDoc.tables.Count '(Counting no of tables in the document) If TableNo = 0 Then MsgBox "This document contains no tables", _ vbExclamation, "Import Word Table" End If End With 

我在word文件上运行一个表格。 然后使用上面提到的代码访问word doc中存在的所有表格。

好的，我附上了一段代码

 'Creating TemplateSheet object Set objTemplateSheetExcelApp = CreateObject("Excel.Application") 'Opening the template to be used objTemplateSheetExcelApp.Workbooks.Open ("C:\Temp\Documents Page XX_US-VC Combo Template.xlsx") Set objTemplateSheetExcelWkBk = objTemplateSheetExcelApp.ActiveWorkbook.Worksheets(5) Set objTemplateSheetExcelSheet = objTemplateSheetExcelApp.ActiveWorkbook.Worksheets(5) '(Selecting the desired tab) tblcount = 1 For tblcount = 1 To TableNo With .tables(tblcount) 'copy cell contents from Word table cells to Excel cells For iRow = 1 To .Rows.Count For iCol = 1 To .Columns.Count On Error Resume Next strEach = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text) For arrycnt = 0 To 15 YNdoc = InStr(strEach, myArray(arrycnt)) If (YNdoc > 0) Then objTemplateSheetExcelSheet.Cells(2, yourArray(arrycnt)) = _ WorksheetFunction.Clean(.cell(iRow, iCol + 1).Range.Text) If arrycnt = 3 Or arrycnt = 6 Then objTemplateSheetExcelSheet.Cells(2, yourArray(arrycnt) + 1) = _ WorksheetFunction.Clean(.cell(iRow + 1, iCol + 1).Range.Text) End If End If Next arrycnt Next iCol Next iRow End With Next tblcount End With intRow = 1 'To save the file strFileName = "Newfile.xlsx" objTemplateSheetExcelWkBk.SaveAs strFld & "\" & strFileName objTemplateSheetExcelApp.Quit Set objTemplateSheetExcelApp = Nothing Set objTemplateSheetExcelWkBk = Nothing Set objTemplateSheetExcelSheet = Nothing Set wdDoc = Nothing 

Answer 1

要从Excel中与Word进行交互，可以select“早期绑定”或“晚期绑定”。 我正在使用Late Binding，您不需要添加任何引用。

我将覆盖5个部分的代码

1. 绑定一个Word实例
2. 打开Word文档
3. 与Word表交互
4. 声明您的Excel对象
5. 将单词表复制到Excel

---

A.绑定一个Word实例

---

声明您的Word对象，然后绑定到Word的现有实例或创build一个新的实例。 例如

 Sub Sample() Dim oWordApp As Object, oWordDoc As Object '~~> Establish an Word application object On Error Resume Next Set oWordApp = GetObject(, "Word.Application") If Err.Number <> 0 Then Set oWordApp = CreateObject("Word.Application") End If Err.Clear On Error GoTo 0 oWordApp.Visible = True End Sub 

---

B.打开Word文档

---

一旦你连接/创build了Word实例，只需打开Word文件即可。看到这个例子

 Sub Sample() Dim oWordApp As Object, oWordDoc As Object Dim FlName As String FlName = Application.GetOpenFilename("Word files (*.Doc*),*.Doc*", , _ "Browse for file containing table to be imported") '~~> Establish an Word application object On Error Resume Next Set oWordApp = GetObject(, "Word.Application") If Err.Number <> 0 Then Set oWordApp = CreateObject("Word.Application") End If Err.Clear On Error GoTo 0 oWordApp.Visible = True '~~> Open the Word document Set oWordDoc = oWordApp.Documents.Open(FlName) End Sub 

---

C.与Word表交互

---

现在你打开文件，让我们连接到Word文档的Table1。

 Sub Sample() Dim oWordApp As Object, oWordDoc As Object Dim FlName As String Dim tbl As Object FlName = Application.GetOpenFilename("Word files (*.Doc*),*.Doc*", , _ "Browse for file containing table to be imported") '~~> Establish an Word application object On Error Resume Next Set oWordApp = GetObject(, "Word.Application") If Err.Number <> 0 Then Set oWordApp = CreateObject("Word.Application") End If Err.Clear On Error GoTo 0 oWordApp.Visible = True Set oWordDoc = oWordApp.Documents.Open(FlName) Set tbl = oWordDoc.Tables(1) End Sub 

---

D.声明你的Excel对象

---

现在我们有Word表格的句柄。 在我们复制之前，让我们设置我们的Excel对象。

 Sub Sample() Dim oWordApp As Object, oWordDoc As Object Dim FlName As String Dim tbl As Object FlName = Application.GetOpenFilename("Word files (*.Doc*),*.Doc*", , _ "Browse for file containing table to be imported") '~~> Establish an Word application object On Error Resume Next Set oWordApp = GetObject(, "Word.Application") If Err.Number <> 0 Then Set oWordApp = CreateObject("Word.Application") End If Err.Clear On Error GoTo 0 oWordApp.Visible = True Set oWordDoc = oWordApp.Documents.Open(FlName) Set tbl = oWordDoc.Tables(1) '~~> Excel Objects Dim wb As Workbook, ws As Worksheet Set wb = Workbooks.Open("C:\Temp\Documents Page XX_US-VC Combo Template.xlsx") Set ws = wb.Sheets(5) End Sub 

---

E.复制词表到Excel

---

最后，当我们有目的地全部设置，只需将表格从Word复制到Excel。 看到这个

 Sub Sample() Dim oWordApp As Object, oWordDoc As Object Dim FlName As String Dim tbl As Object FlName = Application.GetOpenFilename("Word files (*.Doc*),*.Doc*", , _ "Browse for file containing table to be imported") '~~> Establish an Word application object On Error Resume Next Set oWordApp = GetObject(, "Word.Application") If Err.Number <> 0 Then Set oWordApp = CreateObject("Word.Application") End If Err.Clear On Error GoTo 0 oWordApp.Visible = True Set oWordDoc = oWordApp.Documents.Open(FlName) Set tbl = oWordDoc.Tables(1) '~~> Excel Objects Dim wb As Workbook, ws As Worksheet Set wb = Workbooks.Open("C:\Temp\Documents Page XX_US-VC Combo Template.xlsx") Set ws = wb.Sheets(1) tbl.Range.Copy ws.Range("A1").Activate ws.Paste End Sub 

屏幕截图

Word文档

Excel（贴上后）

希望这可以帮助。