Циклировать код

Option Explicit
Sub CountingBlocks()
' not working with dynamic blocks
  Dim oBlocks As AcadBlocks
  Dim oBlock As AcadBlock
  Dim oBlkRef As AcadBlockReference
  Dim oEnt As AcadEntity
  Dim fType(1) As Integer, fData(1)
  Dim oSset As AcadSelectionSet
  Dim blkName As String
  Dim iCount As Integer
  Dim dxfCode, dxfData
  Dim tmp(1)
  Dim blkColl As New Collection
  fType(0) = 0: fData(0) = "INSERT"
  fType(1) = 2
On Error GoTo Err_Trapp
          With ThisDrawing.SelectionSets
               While .Count > 0
                    .Item(0).Delete
               Wend
          End With
Set oSset = ThisDrawing.SelectionSets.Add("$BlkInstances$")
oSset.Clear
Set oBlocks = ThisDrawing.Blocks
  'loop through all block definitions
  For Each oBlock In oBlocks
  If oBlock.IsLayout = False And oBlock.IsXRef = False Then
  blkName = oBlock.Name
  fData(1) = blkName
  dxfCode = fType
  dxfData = fData
  oSset.Select acSelectionSetAll, , , dxfCode, dxfData
  iCount = 0
  For Each oBlkRef In oSset
  iCount = iCount + 1
    Next oBlkRef
    tmp(0) = blkName: tmp(1) = iCount
' comment IF - END IF statement to your suit
    If iCount > 0 Then
    blkColl.Add tmp
    End If
    Erase tmp
    oSset.Clear
    End If
  Next oBlock
  Debug.Print "Used Block Definitions: " & blkColl.Count
  oSset.Delete
  Set oSset = Nothing
  ' convert collection to two-dimensional array
  Dim i As Long, j As Long
  ReDim blkVar(blkColl.Count - 1, 1)
  For i = 1 To blkColl.Count
  blkVar(i - 1, 0) = blkColl.Item(i)(0)
  blkVar(i - 1, 1) = blkColl.Item(i)(1)
  Next
Err_Trapp:
If Err Then
 MsgBox "Error occured:" & vbNewLine & Err.Description
 End If
End Sub

dim det as string
dim i as integer
det="Detail A"
For i= lbound(blkvar,1) to ubound(blkvar,1)
If blkvar(i, 0)= det then '<--ищем позицию в массиве (можно использовать StrComp)
qty = blkvar(i,1)*2
exit for '<--раз нашли, выходим из цикла
end if
next i
msgbox "amount of detail " & chr(34) & det & (chr(34) & "is: " & qty