how to export Bom with purchased, normal and inseparble to different Excel files by iLogic

[王承之pmhker]

hi ,guys.

The assembly includes normal parts purchasedparts and inseparble parts, etc. How to use ilogic to export the BOM of different structure types to different excel files

[checkcheck_master]

Thanks Krieg, I did and try out on some assemblies, no run time errors so far.

[checkcheck_master]

Hello Krieg,

If you have time, would you like to take a look? I added a column Mass to the BOM and then export it and add it together to show a total mass, see image.
I initially tried to sum the column while 'kg' was in te cell with the Substitute command. The only thing I can't seem to do is to do a 'ctrl-shift-enter' from VBA. Then I thought to filter out the 'kg' but I can't really do that either. You can see my tries in the code, can you see where it goes wrong?

' Export_BOM
' Yes, it's VBA Code.
' I think you have to add the a reference to Excel.
' In VBA Editor goto menu "Tools" --> "References".
' Search for the entry "Microsoft Excel xx.0 Object Library" and activate it.

'Modify the strings to your language version
Private Const sBOMStructureType As String = "BOM Structure" ' Name of the column (column header) in BOM for structure type (Normal, Purchased, Inseparable)
        Private Const sAll As String = "All"
     Private Const sNormal As String = "Normal"
  Private Const sPurchased As String = "Purchased"
Private Const sInseparable As String = "Inseparable"

Private Const sPath As String = "C:\Temp\" 'Path to save the exported BOM's to
Private Const sFilename1 As String = "-BOM_Structured_" 'Static part of filename
'Private Const sFilename2 As String = "-BOM_Structured_" 'Static part of filename
Private Const sFilename2 As String = "-BOM_PartsOnly_" 'Static part of filename
Private Const sFilename3 As String = "-BOM_PartsOnly_"  'Static part of filename
'End Private Const (This text is only to show the underscore after 'PartsOnly'

Public Sub Export_BOM()

'Makro assumes:
'- An assemblydocument is open
'- The part type column is NOT excluded in parts only view

'--------------------------------------------------------------------------------------------------
' Set timer
Dim Start As Double
Start = Timer

Dim TimeDateStamp As String
TimeDateStamp = Format(Date, "yyyy-mm-dd") & "_" & Format(Time, "hh:mm:ss")
TimeDateStamp = Replace(TimeDateStamp, ":", "")
'--------------------------------------------------------------------------------------------------

'GoTo Skip

Dim oApp As Inventor.Application
Set oApp = ThisApplication

Dim oAssDoc As AssemblyDocument
Set oAssDoc = oApp.ActiveDocument

' -------------------------------------------------------------------------------------------------
' Get iProperties

' Get the active document.
    Dim oDoc As Document
    Set oDoc = ThisApplication.ActiveDocument
' Get the PropertySets object.
    Dim oPropSets1 As PropertySets
    Set oPropSets1 = oDoc.PropertySets
' Get the design tracking property set.
    Dim oPropSet1 As PropertySet
    Set oPropSet1 = oPropSets1.Item("Inventor Summary Information")
' Get the Revison Number iProperty.
    Dim oRevNumiProp As Property
    Set oRevNumiProp = oPropSet1.Item("Revision Number")
' Get the PropertySets object.
    Dim oPropSets2 As PropertySets
    Set oPropSets2 = oDoc.PropertySets
' Get the design tracking property set.
    Dim oPropSet2 As PropertySet
    Set oPropSet2 = oPropSets2.Item("Design Tracking Properties")
' Get the Description iProperty.
    Dim oDescriptioniProp As Property
    Set oDescriptioniProp = oPropSet2.Item("Description")
   
    'Debug.Print "oRevisionNumiProp: " & oRevNumiProp.Value
    'Debug.Print "oDescriptioniProp: " & oDescriptioniProp.Value
' -------------------------------------------------------------------------------------------------

'Debug.Print oAssDoc.FullFileName
'Debug.Print oAssDoc.FullDocumentName
'Debug.Print oAssDoc.DisplayName
'Debug.Print Left(oAssDoc.DisplayName, Len(oAssDoc.DisplayName) - 4)

Dim strCustDocName As String
strCustDocName = oAssDoc.DisplayName & "-" & oRevNumiProp.Value & " " & oDescriptioniProp.Value

Dim strBOM1 As String
strBOM1 = sPath & strCustDocName & sFilename1 & sAll & " - " & TimeDateStamp & ".xlsx"
Dim strBOM2 As String
strBOM2 = sPath & strCustDocName & sFilename2 & sNormal & " - " & TimeDateStamp & ".xlsx"
Dim strBOM3 As String
strBOM3 = sPath & strCustDocName & sFilename3 & sPurchased & " - " & TimeDateStamp & ".xlsx"
' -------------------------------------------------------------------------------------------------
'' Check if file exist
'If Dir(sPath & sFilename & sNormal & ".xlsx") <> "" Then
'    Call MsgBox("File " & sPath & sFilename & sNormal & ".xlsx already exist.", vbCritical, "ExportBOM")
'    Exit Sub
'ElseIf Dir(sPath & sFilename & sPurchased & ".xlsx") <> "" Then
'    Call MsgBox("File " & sPath & sFilename & sNormal & ".xlsx already exist.", vbCritical, "ExportBOM")
'    Exit Sub
'ElseIf Dir(sPath & sFilename & sInseparable & ".xlsx") <> "" Then
'    Call MsgBox("File " & sPath & sFilename & sNormal & ".xlsx already exist.", vbCritical, "ExportBOM")
'    Exit Sub
'End If
' -------------------------------------------------------------------------------------------------
' Set BOM
Dim oBOM As BOM
Set oBOM = oAssDoc.ComponentDefinition.BOM

oBOM.StructuredViewEnabled = True
oBOM.PartsOnlyViewEnabled = True

Dim oBOMview As BOMView
For Each oBOMview In oBOM.BOMViews
    If oBOMview.ViewType = kStructuredBOMViewType Then
        Call oBOMview.Export(strBOM1, kMicrosoftExcelFormat, sAll)
        'Call oBOMview.Export(strBOM2, kMicrosoftExcelFormat, sNormal)
    End If
    
    If oBOMview.ViewType = BOMViewTypeEnum.kPartsOnlyBOMViewType Then
    'If oBOMview.ViewType = kPartsOnlyBOMViewType Then
        Call oBOMview.Export(strBOM2, kMicrosoftExcelFormat, sNormal)
        Call oBOMview.Export(strBOM3, kMicrosoftExcelFormat, sPurchased)
    End If
    
    If oBOMview Is Nothing Then
    'MsgBox ("Can't get Parts only BOM view")
    MsgBox ("Can't get BOM view")
    Exit Sub
    End If
Next

Skip:

Dim oExcelApp As Excel.Application
Set oExcelApp = GetObject("", "Excel.Application")

If oExcelApp Is Nothing Then
    MsgBox ("Can't get Excel")
    Exit Sub
End If

Dim oWB As Workbook
Set oWB = oExcelApp.Workbooks.Open(strBOM1)
If Not oWB Is Nothing Then
    'Set oWB = Filter(oExcelApp, oWB, sAll)
    If Not oWB Is Nothing Then
        Call DeleteIrrelevantColumns(oExcelApp, oWB)
        Call List_Objects(oExcelApp, oWB, "TableStyleLight10")
        'Call Replace_kg(oExcelApp, oWB)
        Call SumMass(oExcelApp, oWB)
        oWB.Save
    End If
End If

Dim oWB2 As Workbook
Set oWB2 = oExcelApp.Workbooks.Open(strBOM2)
If Not oWB2 Is Nothing Then
    Set oWB2 = Filter(oExcelApp, oWB2, sNormal)
    If Not oWB2 Is Nothing Then
        Call DeleteIrrelevantColumns(oExcelApp, oWB2)
        Call List_Objects(oExcelApp, oWB2, "TableStyleLight12")
        'Call Replace_kg(oExcelApp, oWB2)
        Call SumMass(oExcelApp, oWB2)
        oWB2.Save
    End If
End If

Dim oWB3 As Workbook
Set oWB3 = oExcelApp.Workbooks.Open(strBOM3)
If Not oWB3 Is Nothing Then
    Set oWB3 = Filter(oExcelApp, oWB3, sPurchased)
    If Not oWB3 Is Nothing Then
        Call DeleteIrrelevantColumns(oExcelApp, oWB3)
        Call List_Objects(oExcelApp, oWB3, "TableStyleLight13")
        'Call Replace_kg(oExcelApp, oWB3)
        Call SumMass(oExcelApp, oWB3)
        oWB3.Save
    End If
End If

Dim Result As VbMsgBoxResult
Result = MsgBox("Export done." & vbNewLine & "Elapsed time: " & Format(Timer - Start, "#.00") & " Seconds" & vbNewLine & "View files in Excel?", vbYesNo, "Export_BOM")

If Result = vbYes Then
    oExcelApp.Visible = True
Else
    For Each oWB In oExcelApp.Workbooks
        oWB.Close (False)
    Next
    oExcelApp.Quit
End If

End Sub

Private Function Filter(ByVal oExcelApp As Excel.Application, ByVal oWB As Workbook, ByVal sName As String) As Workbook
    Dim lLastRow As Long
    Dim t As Long
    'lLastRow = oExcelApp.Cells(oWB.ActiveSheet.Rows.Count, 1).End(xlUp).Rows.Row
    ' Alternativ way to find last row
    lLastRow = oWB.ActiveSheet.UsedRange.Rows.Count
            
    'Debug.Print "lLastRow: " & lLastRow
    
    Dim s As Long
    s = FindColumn(oExcelApp, oWB)
    If s = 0 Then
        Call MsgBox("Column BOM Structure Type missing.", vbCritical, "ExportBOM")
        Filter = Nothing
        Exit Function
    End If
    
    For t = lLastRow To 2 Step -1
        If Not oExcelApp.Cells(t, s).Value = sName Then
            oWB.ActiveSheet.Rows(t).Delete Shift:=xlUp
        End If
    Next t
    
    Set Filter = oWB
End Function

Private Function FindColumn(ByVal oExcelApp As Excel.Application, ByVal oWB As Workbook) As Long
    Dim lLastColumn As Long
    lLastColumn = oExcelApp.Cells(1, oWB.ActiveSheet.Columns.Count).End(xlToLeft).Columns.Column
     
    Dim s As Long
    Dim rCells As Range
    For s = lLastColumn To 1 Step -1
        Set rCells = oExcelApp.Cells(1, s)
        If rCells.Value = sBOMStructureType Then
            FindColumn = s
            Exit For
        End If
    Next s
End Function

Private Sub DeleteIrrelevantColumns(ByVal oExcelApp As Excel.Application, ByVal oWB As Workbook)
    Dim oWS As WorkSheet
    Set oWS = oWB.ActiveSheet
          
    Dim currentColumn As Integer
    Dim columnHeading As String

    'ActiveSheet.Columns("L").Delete

    For currentColumn = oWS.UsedRange.Columns.Count To 1 Step -1

        columnHeading = oWS.UsedRange.Cells(1, currentColumn).Value

        'CHECK WHETHER TO KEEP THE COLUMN
        Select Case columnHeading
            Case "Thumbnail", "Item", "BOM Structure", "Part Number", "QTY", "Description", "Material", "Stock Number", "REV", "Thickness", "PartParameters", "Finishing", "Spare part", "Remark", "Fabrication", "Mass"
                'Do nothing
                
            Case "Mass"
            '    'oWS.Columns(currentColumn).Replace What:=" kg", Replacement:=""
            '     oWS.Columns(currentColumn).Replace " kg", vbNullString, xlPart, xlByRows, True
            
            oWS.Columns("Mass").Replace What:=" kg", Replacement:="", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=False
            
            
            Case Else
                'Delete if the cell doesn't contain "ThisText"
                'If InStr(1, ActiveSheet.UsedRange.Cells(1, currentColumn).Value, "Homer", vbBinaryCompare) = 0 Then

                    oWS.Columns(currentColumn).Delete

                'End If
        End Select
    Next

End Sub

Private Sub List_Objects(ByVal oExcelApp As Excel.Application, ByVal oWB As Workbook, ByVal TableStyle As String) ' Create Table
    Dim oWS As WorkSheet
    Set oWS = oWB.ActiveSheet

    ' Get Last Row and Last Column as numbers
    Dim LR As Long
    Dim LC As Long

    'LR = oWS.Cells(Rows.Count, 1).End(xlUp).Row
    'LC = oWS.Cells(1, Columns.Count).End(xlToLeft).Column
     LR = oWS.Cells(oWS.Rows.Count, 1).End(xlUp).Row
     LC = oWS.Cells(1, oWS.Columns.Count).End(xlToLeft).Column
    
    Dim Rng As Range
    Set Rng = oWS.Cells(1, 1).Resize(LR, LC)

    oWS.ListObjects.Add xlSrcRange, xllistobjecthasheaders:=xlYes, Destination:=Rng
    oWS.ListObjects(1).Name = "Table"
    oWS.ListObjects(1).TableStyle = TableStyle '"TableStyleLight21"

    ' Freeze 1st row
    oExcelApp.Application.ScreenUpdating = True
    oWS.Cells(2, 1).Select
    oExcelApp.ActiveWindow.FreezePanes = True
    
    ' AutoFit Columns
    oWS.Cells.EntireColumn.AutoFit
    
    Set oWS = Nothing
    Set oExcelApp = Nothing
    LR = 0
    LC = 0
    
End Sub

Sub SumMass(ByVal oExcelApp As Excel.Application, ByVal oWB As Workbook)
    Dim oWS As WorkSheet
    Set oWS = oWB.ActiveSheet

    ' Get Last Row and Last Column as numbers and Column also as letter to place formula in cell
    Dim LR As Long
    Dim LC As Long
    Dim strLC As String
        
    LR = oWS.Cells(oWS.Rows.Count, 1).End(xlUp).Row
    LC = oWS.Cells(1, oWS.Columns.Count).End(xlToLeft).Column
    strLC = GetColumnLetter(oWS.Cells(1, oWS.Columns.Count).End(xlToLeft).Column)
    
    Debug.Print "Get Column Letter: " & strLC
       
    Dim strValue As String
    ' Here we use the Column LETTER to determine the formula!
       strValue = "=SUM(SUBSTITUTE(" & strLC & "1:" & strLC & LR & ";" & """kg""" & ";" & """""" & ")+0)" & """ kg"""
    'strValue = "=SOM(SUBSTITUEREN(" & strLC & "1:" & strLC & LR & ";" & """kg""" & ";" & """""" & ")+0)" & " kg"
    
    Debug.Print strValue
    '=SOM(SUBSTITUEREN(I3:I8;"kg";"")+0) & " kg"
    ' Here we use the Column NUMBER to place the formula in the cell!
    'oWS.Cells(LR + 2, LC).FormulaLocal = "=SUM(SUBSTITUTE(" & strLC & "2:" & strLC & LR & ";" & """kg""" & ";" & """""" & ")+0)" '& """ & " kg""""
   'oWS.Cells(LR + 2, LC).FormulaLocal = "=SOM(SUBSTITUEREN(" & strLC & "2:" & strLC & LR & ";" & """kg""" & ";" & """""" & ")+0) " & Chr(38) & Chr(34) & " kg" & Chr(34)
    'oWS.Cells(LR + 2, LC).FormulaArray = "=SOM(SUBSTITUEREN(" & strLC & "2:" & strLC & LR & ";" & """kg""" & ";" & """""" & ")+0) "
    
    'oWB(oWS).Range(strLC & "2:" & strLC & LR).FormulaArray = "=SOM(SUBSTITUEREN(" & strLC & "2:" & strLC & LR & ";" & """kg""" & ";" & """""" & ")+0) " & Chr(38) & Chr(34) & " kg" & Chr(34)
    'oWB(oWS).Range(strLC & "2:" & strLC & LR).Calculate
    
End Sub

Function GetColumnLetter(colNum As Long) As String
    Dim vArr
    vArr = Split(Cells(1, colNum).Address(True, False), "$")
    GetColumnLetter = vArr(0)
End Function

Sub Replace_kg(ByVal oExcelApp As Excel.Application, ByVal oWB As Workbook)
    Dim oWS As WorkSheet
    Set oWS = oWB.ActiveSheet
    
    oWS.Columns("Mass").Replace What:=" kg", Replacement:="", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=False
End Sub