Hi, I'm currently working on vba macro that would expand parts list based on cell value. So if any subassembly contains parts or subassemblies with cell value anything else than "No" it would then expand parts list.
This is my code currently:
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
Dim oSheet As Sheet
Set oSheet = oDrawDoc.ActiveSheet
Dim oPartlist As PartsList
Set oPartlist = oSheet.PartsLists.Item(1)
Dim i As Long
Dim FirstRowCount As Integer
Dim LastRowCount As Integer
Do Until FirstRowCount = LastRowCount
FirstRowCount = oPartlist.PartsListRows.Count
For i = 1 To oPartlist.PartsListRows.Count
Dim oCell As PartsListCell
Set oCell = oPartlist.PartsListRows.Item(i).Item("Part Type")
If oCell.Value = "Spare part" Or oCell.Value = "Wear part" Then
oPartlist.PartsListRows.Item(i).Expanded = True
End If
Next
LastRowCount = oPartlist.PartsListRows.Count
Loop
But it doesn't do anything. So any heads up where the problem might be?
Hi there,
The main mistake in the code you are using Do Until but both values are empty. So basically all FirstRowCount and LastRowCount things are equal to 0.
So it will never do the process inside of the Do Until. You should assign them different values.
I dont know is there a special reason for using Do Until but, How about this?
Sub main()
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
Dim oSheet As Sheet
Set oSheet = oDrawDoc.ActiveSheet
Dim oPartlist As PartsList
Set oPartlist = oSheet.PartsLists.Item(1)
Dim i As Integer
Dim row As PartListRow
For Each row In oPartlist.PartsListRows
Dim oCell As PartsListCell
Set oCell = row.Item("Part Type")
If oCell.Value = "Spare part" Or oCell.Value = "Wear part" Then
row.Expanded = True
End If
Next row
End Sub
This sub will expand all rows which have "Spare part" or "Wear part" values on "Part Type") cell.
Also if you want to expand every row which have values different than "No" on "Part Type" cell you can use this code:
Sub main()
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
Dim oSheet As Sheet
Set oSheet = oDrawDoc.ActiveSheet
Dim oPartlist As PartsList
Set oPartlist = oSheet.PartsLists.Item(1)
Dim i As Integer
Dim row As PartListRow
For Each row In oPartlist.PartsListRows
Dim oCell As PartsListCell
Set oCell = row.Item("Part Type")
If Not oCell.Value = "No" Then
row.Expanded = True
End If
Next row
End Sub
Regards
Devrim
Hi, your code works to some extend but after few rows it gives this error
Can you please debug and show in which step is broken.
I did not test it because i dont have drawing file on the machine. If you can share it i can look.
Also maybe you can try code like this
Sub main()
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
Dim oSheet As Sheet
Set oSheet = oDrawDoc.ActiveSheet
Dim oPartlist As PartsList
Set oPartlist = oSheet.PartsLists.Item(1)
Dim i As Integer
Dim row As PartListRow
For Each row In oPartlist.PartsListRows
On Error Resume Next
Dim oCell As PartsListCell
Set oCell = row.Item("Part Type")
If oCell.Value = "Spare part" Or oCell.Value = "Wear part" Then
row.Expanded = True
End If
Next row
End Sub
Also if you have error again, please move the 'On Error Resume Next' line to second line
Hi, this is where it shows the error. Hovering mouse over it the value is "False"
The last solution to this without example files, is this:
Sub main()
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
Dim oSheet As Sheet
Set oSheet = oDrawDoc.ActiveSheet
Dim oPartlist As PartsList
Set oPartlist = oSheet.PartsLists.Item(1)
Dim i As Integer
For i = 1 To oPartlist.PartsListRows.Count + 1
On Error Resume Next
Dim oCell As PartsListCell
Set oCell = oPartlist.PartsListRows.Item(i).Item("Part Type")
If oCell.Value = "Spare part" Or oCell.Value = "Wear part" Then
oPartlist.PartsListRows.Item(i).Expanded = True
End If
Next
End Sub
Also you can try this with 'On Error Resume Next' right below the beginning of the sub, for or if.
This is all I can do now without file.
Regards
Devrim
Hi, now it works fine, but there's still some assemblies which aren't expanded. I guess now it is expanding assembly if the assembly is marked as spare or wear part? I would like it to expand to more deep level like shown in picture ( I expanded this manually.)
I hope this will solve the issue.
I really dont know the topic and I just tried. This is the best I can do. I can not test it because I dont have any drawings.
Please test this and use if it works. If not, throw it away 🙂
Sub main()
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
Dim oSheet As Sheet
Set oSheet = oDrawDoc.ActiveSheet
Dim oPartlist As PartsList
Set oPartlist = oSheet.PartsLists.Item(1)
Dim i As Integer
For i = 1 To oPartlist.PartsListRows.Count + 1
On Error Resume Next
Dim oCell As PartsListCell
Set oCell = oPartlist.PartsListRows.Item(i).Item("Part Type")
If Not oCell.Value = "No" Then
oPartlist.PartsListRows.Item(i).Expanded = True
End If
Dim j As Integer
For j = 1 To oPartlist.PartsListRows.Item(i).ReferencedRows.Count + 1
On Error Resume Next
Dim bomRow As DrawingBOMRow
bomRow = oPartlist.PartsListRows.Item(i).ReferencedRows.Item(j)
Dim k As Integer
For k = 1 To bomRow.Count + 1
Dim bomCell As DrawingBOMCell
bomCell = bomRow.Item("Part Type")
If Not bomCell.Value = "No" And oPartlist.PartsListRows.Item(i).Expanded = False Then
oPartlist.PartsListRows.Item(i).Expanded = True
Exit For
End If
Next
Next
Next
End Sub
Hi. This works pretty well, but I think it needs "Do Until" or some kin of loop, because it doesn't expand all the way to the bottom.
Also I noted that if I remove "On Error Resume Next" the value for bomRow is nothing?
I was looking into this and found out that problem is in the counter. This code works fine but it doesn't take expanded rows into action. I thought that maybe if you can somehow add count to in the beginning and to the end and loop it using Do Until.
I figured this by changing
For i = 1 To oPartlist.PartsListRows.Count + 1
to
For i = 1 To 999
But it isn't right way to do this I guess 😁.
Can't find what you're looking for? Ask the community or share your knowledge.