[英]Clipboard error copying from Excel to Word document
我正在尝试将 Excel 个单元格(单元格 A1 到 A66)中的文本复制到 Word 文档中。 此操作的目标是将其复制并粘贴为 TEXT。 如果直接从 Excel 复制,它将粘贴为 TABLE。
Private Sub Bouton1_Click()
Dim objWord As New Word.Application
With objWord
.Documents.Add
Application.Wait (Now + TimeValue("0:00:01") / 2)
Worksheets("Description2").Cells(1, 1).Copy
Application.Wait (Now + TimeValue("0:00:01") / 2)
.Selection.PasteSpecial xlPasteValues
.Visible = True
End With
Dim i As Integer
For i = 2 To 66
If Worksheets("Description2").Cells(i, 1) = Worksheets("Description2").Cells(i + 1, 1) Then Exit For
With objWord
Application.Wait (Now + TimeValue("0:00:01") / 2)
Worksheets("Description2").Cells(i, 1).Copy
Application.Wait (Now + TimeValue("0:00:01") / 2)
.Selection.PasteSpecial xlPasteValues
.Visible = True
End With
Next i
objWord.Application.Activate
objWord.Application.WindowState = wdWindowStateMaximize
End Sub
此代码在大约 70% 的时间内有效。 当它不起作用时,我会收到此错误(或变体,但始终与剪贴板有关):
运行时错误“4605”:此方法或属性不可用
因为剪贴板为空或无效。
此外,有时会打开一个随机的 OneDrive window。
我已经添加了Application.Wait
行来尝试减慢复制/粘贴的速度,但它并没有做那么多。
如何使我的代码更可靠?
如果您想粘贴为文本,也许:
Sub CopyAsTextToWord()
Dim wordApp As New Word.Application
With wordApp
.Visible = True
.Documents.Add
Worksheets("Description2").Range("A1:A66").Copy
.Selection.PasteSpecial DataType:=wdPasteText
End With
End Sub
如果在另一方面,你要粘贴在每个时间单元一个(这是它看起来像从原始的代码,不知道),也许是一个稍微不同的方式,避免了剪贴板。 将范围读入数组,遍历它,然后使用Selection.TypeText
按顺序“粘贴”每个元素。 可能可以做得更健壮。
Sub TransferAsText()
Dim wordApp As New Word.Application
With wordApp
.Visible = True
.Documents.Add
Dim arr()
arr = Worksheets("Description2").Range("A1:A66").Value
Dim i As Long
For i = LBound(arr, 1) To UBound(arr, 1)
.Selection.TypeText Text:=CStr(arr(i, 1))
Next i
End With
End Sub
单独写一个function,抓取Excel的所有数据
Function GetDataFromExcel()
CreateObject ("Excel.Application")
Dim xlApp As Excel.Application, xObjFD As FileDialog
Set xlApp = New Excel.Application
xlApp.Visible = True
Set xObjFD = Application.FileDialog(msoFileDialogFilePicker)
xObjFD.Title = "Select the excel file location " & FileType
With xObjFD
.AllowMultiSelect = False
.Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm; *.xlsb", 1
.Show
' Selection is not null
If .SelectedItems.Count > 0 Then
xFilePath = .SelectedItems.Item(1)
Else
Exit Function
End If
Dim xlWorkBook As Object, valueCollected As String, _
rowCount As Integer : rowCount = 1
Set xlWorkBook = xlApp.Workbooks.Open(xFilePath, True, False)
xlWorkBook.Activate
Set ArrayValues = New ArrayList
loopToCollectData:
On Error GoTo err
valueCollected = xlApp.ActiveWorkbook.Sheets("Description2").Range("A" & rowCount).Value
If valueCollected <> "" Then
ArrayValues.Add valueCollected
If rowCount < 66 then
rowCount = rowCount + 1
GoTo loopToCollectData
End If
End If
End With
xlWorkBook.Close
xlApp.Visible = False
Exit Function
err:
xlWorkBook.Close
xlApp.Visible = False
MsgBox "Please select the relevant input file!"
End
End Function
一旦收集了数据,它就独立于应用程序,可以在应用程序中使用。
数组也可用于通过使用范围来收集数据。
Function GetDataFromExcel()
' Some Code ===========
dataArrayCollected = Application.Transpose(Range(Cells(1, 1), Cells(66, 1)))
' Some more Code ===========
' No more code =========== 😃 😁
End Function
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.