Clipboard error copying from Excel to Word document - excel

Question

I am trying to copy text in Excel cells (cell A1 to A66) into a Word document. The goal of this operation is to copy it and paste it as TEXT. If copied directly from Excel, it will paste as a 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
This code works about 70% of the time. When it doesn't work, I get this error (or a variation, but always concerning the clipboard):
Run-Time error "4605": This method or property is not available
because the clipboard is empty or not valid.
Also, sometimes a random OneDrive window opens.
I've added the Application.Wait lines to try to slow down the copy/paste, but it doesn't do that much.
How can I make my code more reliable?

Answer 1

If you want to paste as text, perhaps:
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
If on the other hand you want to paste each cell one at a time (this is what it seems like from your original code, not sure), perhaps a slightly different approach, avoiding the clipboard. Read the range into an array, iterate through it and then use Selection.TypeText to "paste" each element sequentially. Probably can be made more robust.
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

Answer 2

Write a separate function and capture all data from 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
Once data is collected, then it is independent of the application and could be used inside the word application.
An Array could be also used to collect the data by using the range.
Function GetDataFromExcel()
' Some Code ===========
dataArrayCollected = Application.Transpose(Range(Cells(1, 1), Cells(66, 1)))
' Some more Code ===========
' No more code =========== 😃 😁
End Function