Path: csiph.com!usenet.blueworldhosting.com!feeder01.blueworldhosting.com!border2.nntp.dca1.giganews.com!Xl.tags.giganews.com!border1.nntp.dca1.giganews.com!nntp.giganews.com!local2.nntp.dca.giganews.com!nntp.newsgroupbanter.com!news.newsgroupbanter.com.POSTED!not-for-mail NNTP-Posting-Date: Mon, 06 Jun 2016 12:49:01 -0500 From: TimLeonard Newsgroups: microsoft.public.excel.programming Subject: Re: Modify Code to loop back through table after its been updated and process it Date: Mon, 6 Jun 2016 18:27:51 +0100 Message-ID: Organization: ExcelBanter.com User-Agent: X-Newsreader: X-Originating-IP: References: Lines: 248 X-Usenet-Provider: http://www.giganews.com X-Trace: sv3-E6AEGTKxfFQAVFy+FsFkhYeyePDP3Z6hlmCnJemPFgb1rhgxlTrSykBFYIWFHEkvKiOIMCWrxwAykga!BCXVVKuZZ7HX+qVt0yhjqdSCeO9KYZk5ZFycS76ReYrK6yntrRi7sNUKjldsEmKaAPTwpOHFD0xR!59H2dLvQdlFl X-Complaints-To: abuse@newsgroupbanter.com X-Abuse-and-DMCA-Info: Please be sure to forward a copy of ALL headers X-Abuse-and-DMCA-Info: Otherwise we will be unable to process your complaint properly X-Postfilter: 1.3.40 X-Original-Lines: 236 X-Original-Bytes: 7211 Xref: csiph.com microsoft.public.excel.programming:108891 Thank you for the tips, I did use it, however I still need a little help looping through it. I tried but its not working...I need a little more direction Thanks again > > > Similarly, you could load your Attribute Table into an array and 'dump' > > it into the worksheet in 1 shot.(Note that this needs to be a 2D array > for all to work smoothly!) -- > > Not sure where in the code or how to apply this suggestion > > Code: -------------------- Sub ExtractAtts_With_Filters() Dim Xl As Excel.Application Dim XlSheet As Object Dim XlWorkbook As Object Dim RowNum As Integer Dim Header As Boolean Dim elem As AcadEntity Dim Array1 As Variant Dim count As Integer 'Dim blk As AcadBlockReference '**************************************************** 'Delete the .xls Attribute Report File Dim KillFile As String varPath = ThisDrawing.Path On Error GoTo Exit_XL_App KillFile = varPath & "\" & "Attribute.xls" 'Check that file exists If Len(Dir$(KillFile)) > 0 Then 'First remove readonly attribute, if set SetAttr KillFile, vbNormal 'Then delete the file Kill KillFile End If ' Launch Excel and Get Attributes***************************. Set Xl = New Excel.Application Xl.Visible = True ' Create a new workbook and find the active sheet. Set XlWorkbook = Xl.Workbooks.Add Set XlSheet = Xl.ActiveSheet XlWorkbook.SaveAs fileName:=varPath & "\" & "Attribute.xls", FileFormat:=1 RowNum = 1 Header = False ' Iterate through model space finding ' all block references. For Each elem In ThisDrawing.ModelSpace With elem ' When a block reference has been found, ' check it for attributes If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then If .HasAttributes Then ' Get the attributes Array1 = .GetAttributes ' Filter through a list of attribute tagstrings in the current block. ' Cycle throught the list of attributes. For i = LBound(Array1) To UBound(Array1) ' Check for the correct attribute tag. Dim Attrib As AcadAttributeReference Set Attrib = Array1(i) ' If the Tagstring containd "Addresses" then ' Copy the Tagstrings into Excel If Attrib.TagString = "ADDRESS" Then ' Copy the Tagstrings for the ' Attributes into Excel For count = LBound(Array1) To UBound(Array1) If Header = False Then If StrComp(Array1(count).EntityName, "AcDbAttribute", 1) = 0 Then XlSheet.Range("A1") = "HANDLE" 'Code below adds column names XlSheet.Cells(RowNum, count + 2).value = Array1(count).TagString End If End If Next count RowNum = RowNum + 1 For count = LBound(Array1) To UBound(Array1) If XlSheet.Range("A" & RowNum) = False Then XlSheet.Range("A" & RowNum) = "'" & "'" & elem.Handle 'Fill the columns with block data from modelspace End If XlSheet.Cells(RowNum, count + 2).value = Array1(count).TextString Next count Header = True End If Next i 'Next Filter Check End If End If End With Next elem Xl.Sheets("Sheet1").Cells.EntireColumn.AutoFit '*********************************************************** ' Code to import a field database and update the attribute table '*********************************************************** Dim ssnew As Object Dim Entity As AcadEntity Dim blkEntity As AcadBlockReference Dim n As Variant 'Defaults to Variant Dim Handle As String Dim blockName As String Dim tag As String Dim Loops As String Dim Address As String Dim Label1 As String Dim Label2 As String Dim Device_Label As String Dim Extended_Label As String Dim Qty As String Dim Model_Num As String Dim Description As String Dim Vendor As String Dim CSFM_Num As String Dim vAttrData vAttrData = XlSheet.UsedRange ' Make Selection set of Blocks ' ---------------------------- Set activeDoc = ThisDrawing.Application.ActiveDocument ThisDrawing.ActiveSpace = acModelSpace With activeDoc Set setColl = .SelectionSets For Each setObj In .SelectionSets If setObj.Name = "VBA" Then .SelectionSets.Item("VBA").Delete Exit For End If Next Set ssnew = activeDoc.SelectionSets.Add("VBA") End With ssnew.Select acSelectionSetAll ' Get Attribute values For Each Entity In ssnew If Entity.ObjectName = "AcDbBlockReference" Then Set blkEntity = Entity If blkEntity.HasAttributes Then Dim newAttribs As Variant newAttribs = blkEntity.GetAttributes For n = LBound(newAttribs) To UBound(newAttribs) Select Case newAttribs(n).TagString Case "HANDLE" Handle = newAttribs(n).TextString Case "BLOCKNAME" blockName = newAttribs(n).TextString Case "TAG" tag = newAttribs(n).TextString Case "LOOP" Loops = newAttribs(n).TextString Case "ADDRESS" Address = newAttribs(n).TextString Case "LABEL1" Label1 = newAttribs(n).TextString Case "LABEL2" Label2 = newAttribs(n).TextString Case "DEVICE_LABEL" Device_Label = newAttribs(n).TextString Case "EXTENDED_LABEL" Extended_Label = newAttribs(n).TextString Case "QTY" Qty = newAttribs(n).TextString Case "MODEL_NUM" Model_Num = newAttribs(n).TextString Case "DESCRIPTION" Description = newAttribs(n).TextString Case "VENDOR" Vendor = newAttribs(n).TextString Case "CSFM_NUM" CSFM_Num = newAttribs(n).TextString End Select Next n 'Entity(n).Update 'This line does not work End If End If Next Entity '************************************************************ Exit_XL_App: MsgBox Err.Number & " - " & Err.Description & " Error occurred in Excel App Process" Xl.DisplayAlerts = False 'XlBook.Save XlWorkbook.Close True '*** uncomment to keep open Xl.DisplayAlerts = True Xl.Quit Set XlSheet = Nothing Set XlWorkbook = Nothing Set Xl = Nothing Exit_Sub: End Sub [\code] -- TimLeonard