Question

我的问题是在我通过创建OLEObject将表格从Microsoft Word导入Excel后，它不会让我将表格复制并粘贴到Excel中。它会不断粘贴我在剪贴板上最后复制的内容到第一个单元格中。目前，我的代码向用户询问文件名，将该文件作为活动Excel工作表中的OLEObject打开，然后将不正确的信息粘贴到单元格A1中。它不是复制和粘贴Word OLEObject中的内容。

 Sub Macro1()
    Dim FName As String, FD As FileDialog
    Dim ExR As Range
    Set FD = Application.FileDialog(msoFileDialogOpen)
    FD.Show
    If FD.SelectedItems.Count <> 0 Then
        FName = FD.SelectedItems(1)
    Else
        Exit Sub
    End If

    ActiveSheet.OLEObjects.Add(fileName:=FName, Link:=False, DisplayAsIcon:=False).Select
    Selection.Verb Verb:=xlPrimary
    Range("A1").Select
    ActiveSheet.Paste

End Sub

谢谢！

Answer 1

从Word到Excel，应该是这样的。

Sub ImportFromWord()

'Activate Word Object Library

'Dim WordApp As Word.Application    
Dim WordDoc As Word.Document

Set WordApp = CreateObject("word.application") ' Open Word session

WordApp.Visible = False 'keep word invisible
Set WordDoc = WordApp.Documents.Open("C:\Users\your_path_here_\WordFile.docx") ' open Word file

'copy third row of first Word table
WordDoc.Tables(1).Rows(3).Range.Copy

'paste in Excel
Range("A1").PasteSpecial xlPasteValues

WordDoc.Close 'close Word doc
WordApp.Quit ' close Word

End Sub

或者这个。

Sub GetTables() 

FName = Application _ 
.GetOpenFilename("Word Files (*.doc), *.doc") 

Set WordObject = GetObject(FName) 

First = True 
RowCount = 2 
For Each Tble In WordObject.tables 
For i = 1 To 22 
If First = True Then 
Data = Tble.Rows(i).Cells(1).Range 
'Remove cell markers 
Cells(1, i) = Left(Data, Len(Data) - 2) 
End If 
Data = Tble.Rows(i).Cells(2).Range.Text 
'Remove cell markers 
Cells(RowCount, i) = Left(Data, Len(Data) - 2) 
Next i 
RowCount = RowCount + 1 
First = False 
Next Tble 
WordObject.Close savechanges = False 
End Sub

Answer 2

使用链接How to preserve source formatting while copying data from word table to excel sheet using VB macro?中的代码，当宏将Word表格粘贴到一个全新的单独工作簿中时，我只能使代码生效。当单击我要导入Word表格的excel工作簿中的命令按钮时，表格永远不会粘贴到名为“Scraping Sheets”的工作表中，我已经弄乱了代码，但最接近的是我能得到的是放置将整个表格放入一个格式，所有格式都丢失了。

Private Sub CommandButton22_Click()
Dim oWordApp As Object, oWordDoc As Object
Dim FlName As String
Dim tbl As Object

FlName = Application.GetOpenFilename("Word files (*.Doc*),*.Doc*", , _

On Error Resume Next
Set oWordApp = GetObject(, "Word.Applicaton")

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)

Dim wb As Workbook, ws As Worksheet

Set wb = Workbooks.Open(""C:\Users\xxxx\Desktop\292 Int'l_Weekly_Win_Loss_YYYY MM DD TEMPLATE.xlsm"")

Set ws = wb.Sheets("Scraping Sheet")

tbl.Range.Copy

ws.Range("A1").Activate

ws.Paste

MsgBox "Successfully Added File!"
End Sub

复制＆amp;通过VBA将Microsoft Word OLEObject中的信息粘贴到Excel文件中

2 个答案: