Sub CreateBlockListInExcel()
 
 
 
	'************************************
 
	'Downloaded from VisibleVisual.com
 
	'Free to use
 
	'To use this macro in AutoCad make sure that the reference is set to Microsoft Excel XX Object Library
 
	'************************************
 
	Dim blk As AcadBlockReference
 
	Dim wrkb As Excel.Workbooks
 
	Dim wrks As Excel.Worksheet
 
	On Error Resume Next
 
	'Check if Excel is open and if not open it.
 
	Set objExcel = GetObject(, "Excel.Application")
 
	If Err.Number > 0 Then
 
	Set objExcel = CreateObject("Excel.Application")
 
	End If
 
	'Make sure excel is visible anddsv add a new workbook
 
	objExcel.Visible = True
 
	Set wrkb = objExcel.Workbooks.Add
 
	Set wrks = objExcel.ActiveSheet
 
	Dim rownr As Double
 
	rownr = 1
 
	'Loop through modespace
 
	For Each blk In ThisDrawing.ModelSpace
 
	rownr = rownr + 1
 
	'Code below adds column names
 
	wrks.Range("A1") = "BLOCKNAME"
 
	wrks.Range("B1") = "LAYERNAME"
 
	wrks.Range("C1") = "EFFECTIVENAME"
 
	wrks.Range("D1") = "X"
 
	wrks.Range("E1") = "Y"
 
	wrks.Range("F1") = "Z"
 
	'wrks.Range("G1") = "NEW COLUMN NAME"
 
	'Fill the columns with block data from modelspace
 
	wrks.Range("A" & rownr) = blk.Name
 
	wrks.Range("B" & rownr) = blk.Layer
 
	wrks.Range("C" & rownr) = blk.EffectiveName
 
	wrks.Range("D" & rownr) = blk.InsertionPoint(0)
 
	wrks.Range("E" & rownr) = blk.InsertionPoint(1)
 
	wrks.Range("F" & rownr) = blk.InsertionPoint(2)
 
	'wrks.Range("G" & rownr) = blk. .....Extend/change the column to any value you like
 
	Next
 
	End Sub