Помогите !! бьюсь уже неделю !!

Dim ent as acadentity
dim blk as acadblockreference
dim i as integer
dim ar()as acadobject
For each ent in thisdrawing.modelspace
if typeof ent is acadblockreference then
set blk =ent
end if
if blk.name like "`*@*" then
redim preserve ar(i)as acadobject
set ar(i)=blk
i=i+1
end if
next ent

Option Explicit
Sub test2()
'very quick sample, no error checking
'but it may get you started
Dim oDocA As AcadDocument
Dim oDocB As AcadDocument
Set oDocA = ThisDrawing
'this assumes that you have a drawing named "test2.dwg" open in this session
Set oDocB = ThisDrawing.Application.Documents("CHECKS.dwg") '<--куда вставлять
'this is just there to show the doc is valid
MsgBox oDocB.Name
'set up the block you want to copy to
'in this case model space of docB
Dim oMSB As AcadModelSpace
Set oMSB = oDocB.ModelSpace
'get selection set
Dim ss As AcadSelectionSet
On Error Resume Next
Set ss = oDocA.SelectionSets.Add("sant")
If Err Then
oDocA.SelectionSets.Item("sant").Delete
Err.Clear
Set ss = oDocA.SelectionSets.Add("sant")
End If
On Error GoTo Sayme
ss.SelectOnScreen
'create array to hold items
Dim oent As AcadEntity
'must be dynamic since you don't know how many items
Dim eArray() As Object
'resize to how many items
ReDim eArray(0 To ss.Count - 1)
'put selection set items into an array
Dim i As Long
For i = 0 To ss.Count - 1
Set eArray(i) = ss.Item(i)
Next i
'pass array to copy objects method
oDocA.CopyObjects eArray, oMSB
Sayme:
MsgBox Err.Description
End Sub

Option Explicit
Sub CopyBlocksToOtherDwg()
'very quick sample, no error checking
'but it may get you started
Dim oDocA As AcadDocument
Dim oDocB As AcadDocument
Set oDocA = ThisDrawing
'this assumes that you have a drawing named "test2.dwg" open in this session
Set oDocB = ThisDrawing.Application.Documents(1)
'this is just there to show the doc is valid
'set up the block you want to copy to
'in this case model space of docB
Dim oMSB As AcadModelSpace
Set oMSB = oDocB.ModelSpace
'get selection set
Dim ss As AcadSelectionSet
Dim ftype(0 To 1) As Integer
Dim fdata(0 To 1) As Variant
ftype(0) = 0: ftype(1) = 2
fdata(0) = "INSERT": fdata(1) = "`*@*"
          With oDocA.SelectionSets
               While .Count > 0
                    .Item(0).Delete
               Wend
          End With
Set ss = oDocA.SelectionSets.Add("$blocks$")
On Error GoTo Sayme
ss.Select acSelectionSetAll, , , ftype, fdata
MsgBox ss.Count
'create array to hold items
Dim oent As AcadEntity
'must be dynamic since you don't know how many items
Dim eArray() As Object
'resize to how many items
ReDim eArray(0 To ss.Count - 1)
'put selection set items into an array
Dim i As Long
For i = 0 To ss.Count - 1
Set eArray(i) = ss.Item(i)
Next i
'pass array to copy objects method
oDocA.CopyObjects eArray, oMSB
Sayme:
MsgBox Err.Description
End Sub

Dim InsertPnt As Variant,BlockName as string
Dim insertedBlock As AcadBlockReference
BlockName="NNN"
InsertPnt = ThisDrawing.Utility.GetPoint(, vbCrLf & "Укажите точку вставки блока:")
Set insertedBlock = ThisDrawing.ModelSpace.InsertBlock(InsertPnt, BlockName, 1#, 1#, 1#, 0#)