Announcements

Starting in December, we will archive content from the community that is 10 years and older. This FAQ provides more information.

Expand structured parts list based on cell value

Inventor_Enjoyer
Contributor
Contributor

Expand structured parts list based on cell value

Inventor_Enjoyer
Contributor
Contributor

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.

Inventor_Enjoyer_0-1668082684058.png

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?

 

 

0 Likes
Reply
480 Views
10 Replies
Replies (10)

Dev_rim
Advocate
Advocate

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

If my answer is solved your problem, please mark it as Solution

Freundliche Grüße / Kind Regards
0 Likes

Inventor_Enjoyer
Contributor
Contributor

Hi, your code works to some extend but after few rows it gives this error

Inventor_Enjoyer_0-1668085124453.png

 

0 Likes

Dev_rim
Advocate
Advocate

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

If my answer is solved your problem, please mark it as Solution

Freundliche Grüße / Kind Regards
0 Likes

Inventor_Enjoyer
Contributor
Contributor

Hi, this is where it shows the error. Hovering mouse over it the value is "False"

Inventor_Enjoyer_0-1668086400031.png

 

0 Likes

Dev_rim
Advocate
Advocate

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

If my answer is solved your problem, please mark it as Solution

Freundliche Grüße / Kind Regards

Inventor_Enjoyer
Contributor
Contributor

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.)

Inventor_Enjoyer_0-1668087978035.png

 

0 Likes

Dev_rim
Advocate
Advocate

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

 

 

If my answer is solved your problem, please mark it as Solution

Freundliche Grüße / Kind Regards

Inventor_Enjoyer
Contributor
Contributor

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.

Inventor_Enjoyer_1-1668151086982.png

 

 

 

0 Likes

Inventor_Enjoyer
Contributor
Contributor

Also I noted that if I remove "On Error Resume Next" the value for bomRow is nothing?

Inventor_Enjoyer_0-1668159261169.png

 

0 Likes

Inventor_Enjoyer
Contributor
Contributor

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 😁.

0 Likes