Импорт данных из Excel в Acad.

Option Explicit
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
' Tested on A2009 only
' Require:
' Microsoft Excel XX.0 Object Library
' Tools --> Options --> General tab --> Error trapping --> Break on Unhandled Errors
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Const xlFileName As String = "C:\UsedFiles\points.xls" '<-- change Excel file name here
Const rngAddress As String = "$A$2:$C$27" '<-- change Excel range address here

   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Public Sub PointstoAcad()
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.worksheet
    Dim xlRange As Excel.Range
    
    Set xlApp = CreateObject("Excel.Application")
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
    On Error GoTo Error_Control
    
    With xlApp
        .Visible = False 'True
        Set xlBook = .Workbooks.Open(xlFileName)
    End With
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
   Set xlSheet = xlApp.ActiveSheet '<-- or set sheet by  name, e.g.: Set xlSheet = xlApp.Sheets("Sheet1")

    Set xlRange = xlSheet.Range(rngAddress)
    xlRange.Select
    Dim Pts As Variant
Pts = xlRange.Value
Dim nr As Long, nc As Long
nr = xlRange.Rows.Count
nc = xlRange.Columns.Count
Dim i As Long, j As Long
For i = 1 To nr '<-- starts from 1
Dim pt(2) As Double
Dim u As Integer
u = 0
For j = 1 To nc '<-- starts from 1
pt(u) = RQPT(Trim(CStr(Pts(i, j))))

u = u + 1
Next 'row
ThisDrawing.ActiveLayout.Block.AddPoint (pt)'<--Тут выпоняешь любую другую команду (напр. вставку блока в эту точку)
''debug only:
Debug.Print CStr(pt(0)) & " ; " & CStr(pt(1)) & " ; " & CStr(pt(2))
Next 'column
  ZoomExtents
  MsgBox "Done"
Exit_Here:
    xlBook.Close False
    xlApp.Quit

    Set xlBook = Nothing
    Set xlApp = Nothing
Exit Sub

Error_Control:
If Err.Number <> 0 Then
Err.Clear
MsgBox Err.Description
Resume Exit_Here
End If
End Sub

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Function RQPT(dblValue As String) As Double
RQPT = Val(Replace(dblValue, ",", ".", 1, -1, vbTextCompare))
End Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'