Copying a range of cells from an excel document to an AutoCAD drawing with VBA

[Anonymous]

I'm trying to figure out how to automate copying and pasting a varying range of cells as a table into an AutoCAD drawing with VBA. I'm able to do it no worries by just selecting the cells in excel with a mouse, pressing Ctrl+C and then going into the drawing and pasting it, but for some reason when i use: 

LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

ActiveSheet.Range("A4:D" & LastRow).Copy

it only copies the text, and i would like the table to keep the same formatting as it has in the excel worksheet.

Then, once it is copied i cant figure out how to code for pasting the table into the drawing.

Any help would be appreciated, thanks!

[norman.yuan · Accepted solution]

There is no direct COM API  that enable inserting copied Excel sheet/range into drawing as OLE object (thus keeping the sheet/range's formatting). I'd rather copy data from the sheet and place the data into native AutoCAD table, where you can format the AutoCAD table freely and eliminate the drawing's dependency to Excel application.

However, you can use SendCommand to execute "_pasteclip" command to paste whatever is copied to Windows' clipboard.

The code bellow shows 2 macros: one does the paste after user manually copied a range on an worksheet; the other let AutoCAD connect to the opened Excel Application's active sheet and select a range, then call Range.Copy to get the range data into Windows' clipboard, and paste into drawing.

Option Explicit

Public Sub PasteSheetRange01()

    Dim msg As String
    msg = "Please make sure you have just copied a selected range in" & vbCrLf & _
        "an open Excel sheet before continue." & vbCrLf & vbCrLf & _
        "Do you want to continue?"
    
    If MsgBox(msg, vbYesNo) = vbNo Then Exit Sub
    
    InsertSheetRange
    
End Sub

Public Sub PasteSheetRange02()

    Dim sh As Excel.Worksheet
    Dim rng As Excel.Range
    
    Set sh = GetExcelSheet()
    If sh Is Nothing Then
        MsgBox "Excel Application is not running, or" & vbCrLf & _
        "opened Excel file does not have ""SHEET1""."
        Exit Sub
    End If
    
    Set rng = sh.Range("A1", "D10")
    rng.Copy
    
    InsertSheetRange

End Sub

Private Function GetExcelSheet() As Excel.Worksheet

    Dim theSheet As Excel.Worksheet
    Dim sh As Excel.Worksheet
    Dim xls As Excel.Application
    
    On Error Resume Next
    
    '' Assume the worksheet is aleady opened on Excel Application
    '' for simplicity, I omitted the code to launch Excel and open
    '' *.xls file
    Set xls = GetObject(, "Excel.Application")
    If Not xls Is Nothing Then
    
        For Each sh In xls.ActiveWorkbook.Worksheets
            If UCase(sh.Name) = "SHEET1" Then
                Set xls.ActiveSheet = sh
                Set theSheet = sh
                Exit For
            End If
        Next
        
    End If
    
    Set GetExcelSheet = theSheet
    
End Function

Private Sub InsertSheetRange()

    Dim pt As Variant
    On Error Resume Next
    pt = ThisDrawing.Utility.GetPoint(, vbCr & "pick sheet insertion point (lower-left corner):")
    If Err.Number <> 0 Then Exit Sub
    
    ThisDrawing.SendCommand "pasteclip" & vbCr & pt(0) & "," & pt(1) & vbCr
    
End Sub

After the macro execution, the "OLE Text Size" dialog box may pops up, though.

[Anonymous]

Thank you so much, that last sub was exactly what i needed!!