Export several partlist to one excel book

[EMVC]

Hello

is there a vba thats can export several parts list to one excel book

Lets say may poject in one order is based on 10 idw files , can that easealy be exported to one excel book not sheet

one partlist one one tab

[HideoYamada]

Hello,

I made sample code that collect the BOMs of the drawing documents which are opened.

Option Explicit

Private Const TempWorkBookName = "TempWorkBook.xlsx"
Private oExcelApp As Excel.Application
Private TempWorkbookFullName As String

Public Sub CollectOpenedIdwBOMs()
    ' Init WSH and temp path
    Dim WSH As Variant
    Set WSH = CreateObject("WScript.Shell")
    TempWorkbookFullName = WSH.SpecialFolders("Desktop") & "\" & TempWorkBookName
    

    ' Setup Excel
    Set oExcelApp = CreateObject("Excel.Application")
    oExcelApp.Visible = True
    oExcelApp.DisplayAlerts = False
    Dim oWorkbook As Workbook
    Set oWorkbook = oExcelApp.Workbooks.Add
    
    ' Create AssyDoc collection
    Dim oAssyDocs As ObjectCollection
    Set oAssyDocs = CreateAssyDocs
    
    ' Collect BOMs into one workbook
    MsgBox "Start Step 1"
    CollectBOMsFromDocs oAssyDocs, oWorkbook
    
    ' Combine worksheets into one sheet
    MsgBox "Start Step 2"
    CombineWorksheets oWorkbook
    
    ' end
    oExcelApp.DisplayAlerts = True
    Set oExcelApp = Nothing
    MsgBox "End"
End Sub

Private Function CreateAssyDocs() As ObjectCollection
    Set CreateAssyDocs = ThisApplication.TransientObjects.CreateObjectCollection
    Dim oDoc As Document
    For Each oDoc In ThisApplication.Documents
        If TypeOf oDoc Is DrawingDocument Then
            Dim oDrawingDoc As DrawingDocument
            Set oDrawingDoc = oDoc
            Dim oRefedDoc As Document
            Set oRefedDoc = oDrawingDoc.ActiveSheet.DrawingViews(1).ReferencedDocumentDescriptor.ReferencedDocument
            If TypeOf oRefedDoc Is AssemblyDocument And oRefedDoc.ComponentDefinition.BOM.StructuredViewEnabled Then
                CreateAssyDocs.Add oRefedDoc
            End If
        End If
    Next oDoc
End Function

Private Sub CollectBOMsFromDocs(oAssyDocs As ObjectCollection, oWorkbook As Workbook)
    Dim oAssyDoc As AssemblyDocument
    For Each oAssyDoc In oAssyDocs
        ExportBOMAsWorkbook oAssyDoc
        Dim oTempWorkbook As Workbook
        Set oTempWorkbook = oExcelApp.Workbooks.Open(TempWorkbookFullName)
        oTempWorkbook.Sheets(1).Move After:=oWorkbook.Sheets(1)
        Kill TempWorkbookFullName
    Next oAssyDoc
End Sub

Private Sub CombineWorksheets(oWorkbook As Workbook)
    If oWorkbook.Sheets.Count <= 1 Then
        Exit Sub
    End If
    
    ' Copy title line
    oWorkbook.Sheets(2).Rows(1).Copy oWorkbook.Sheets(1).Rows(1)
    
    ' Copy all sheets into one
    Dim oSheet As WorkSheet
    Dim rowIndex As Integer
    rowIndex = 2
    
    While oWorkbook.Sheets.Count > 1
        Dim r As Range
'        Set r = oWorkbook.Sheets(2).Cells(2, 1)
'        Set r = Range(r, r.End(xlDown)).EntireRow
        Set r = oWorkbook.Sheets(2).Rows("2:" & oWorkbook.Sheets(2).Cells(2, 1).End(xlDown).Row)
        r.Copy oWorkbook.Sheets(1).Cells(rowIndex, 1)
        rowIndex = rowIndex + r.Rows.Count
        oWorkbook.Sheets(2).Delete
    Wend
End Sub

Private Sub ExportBOMAsWorkbook(oAssyDoc As AssemblyDocument)
    Call oAssyDoc.ComponentDefinition.BOM.BOMViews("Structured").Export(TempWorkbookFullName, kMicrosoftExcelFormat, oAssyDoc.DisplayName)
End Sub

See the video also :

https://autode.sk/2mzItnR

Is this code helping you?

=====

Freeradical

 Hideo Yamada

[EMVC]

Hello

It seems that i have done something , becouse it is not working

[EMVC]

Hello

and thank you i look at video and it seems like what i want

[HideoYamada]

Hi EMVC,

These four lines must be deleted.

(They don't exist in original code which I posted.)

=====

Freeradical

 Hideo Yamada

[EMVC]

I can not understand what i do wrong, i have placed the code under Module 1

[HideoYamada]

Hello,

You must add Reference to Excel Object Library in Inventor.

VBA Editor -> Tools -> References -> :

[EMVC]

Hello

Thank you now i getting somwhere, but i get data from Bill of materials not Partlist, se pictures

[EMVC]

Hello

And all comes in one sheet i have 3 idw files open,

[HideoYamada · Accepted solution]

Hi EMVC,

If you need Part List on the drawing document, delete all the codes and insert follows :

Option Explicit

Private Const TempWorkBookName = "TempWorkBook.xlsx"
Private oExcelApp As Excel.Application
Private TempWorkbookFullName As String

Public Sub CollectOpenedIdwPartLists()
    ' Init WSH and temp path
    Dim WSH As Variant
    Set WSH = CreateObject("WScript.Shell")
    TempWorkbookFullName = WSH.SpecialFolders("Desktop") & "\" & TempWorkBookName
    
    ' Setup Excel
    Set oExcelApp = CreateObject("Excel.Application")
    oExcelApp.Visible = True
    oExcelApp.DisplayAlerts = False
    Dim oWorkbook As Workbook
    Set oWorkbook = oExcelApp.Workbooks.Add
    
    ' Create DrawingDoc collection
    Dim oDrawingDocs As ObjectCollection
    Set oDrawingDocs = CreateDrawingDocs
    
    ' Collect BOMs into one workbook
    MsgBox "Start Step 1"
    CollectPartListsFromDocs oDrawingDocs, oWorkbook
    
    ' Combine worksheets into one sheet
    MsgBox "Start Step 2"
    CombineWorksheets oWorkbook
    
    ' end
    oExcelApp.DisplayAlerts = True
    Set oExcelApp = Nothing
    MsgBox "End"
End Sub

Private Function CreateDrawingDocs() As ObjectCollection
    Set CreateDrawingDocs = ThisApplication.TransientObjects.CreateObjectCollection
    Dim oDoc As Document
    For Each oDoc In ThisApplication.Documents
        If TypeOf oDoc Is DrawingDocument Then
            Dim oDrawingDoc As DrawingDocument
            Set oDrawingDoc = oDoc
            If oDrawingDoc.ActiveSheet.PartsLists.Count > 0 Then
                CreateDrawingDocs.Add oDrawingDoc
            End If
        End If
    Next oDoc
End Function

Private Sub CollectPartListsFromDocs(oDrawingDocs As ObjectCollection, oWorkbook As Workbook)
    Dim oDrawingDoc As DrawingDocument
    For Each oDrawingDoc In oDrawingDocs
        ExportPartListAsWorkbook oDrawingDoc
        Dim oTempWorkbook As Workbook
        Set oTempWorkbook = oExcelApp.Workbooks.Open(TempWorkbookFullName)
        oTempWorkbook.Sheets(1).Move After:=oWorkbook.Sheets(1)
        Kill TempWorkbookFullName
    Next oDrawingDoc
End Sub

Private Sub CombineWorksheets(oWorkbook As Workbook)
    If oWorkbook.Sheets.Count <= 1 Then
        Exit Sub
    End If
    
    ' Copy title line
    oWorkbook.Sheets(2).Rows(1).Copy oWorkbook.Sheets(1).Rows(1)
    
    ' Copy all sheets into one
    Dim oSheet As WorkSheet
    Dim rowIndex As Integer
    rowIndex = 2
    
    While oWorkbook.Sheets.Count > 1
        Dim r As Range
'        Set r = oWorkbook.Sheets(2).Cells(2, 1)
'        Set r = Range(r, r.End(xlDown)).EntireRow
        Set r = oWorkbook.Sheets(2).Rows("2:" & oWorkbook.Sheets(2).Cells(2, 1).End(xlDown).Row)
        r.Copy oWorkbook.Sheets(1).Cells(rowIndex, 1)
        rowIndex = rowIndex + r.Rows.Count
        oWorkbook.Sheets(2).Delete
    Wend
End Sub

Private Sub ExportPartListAsWorkbook(oDrawingDoc As DrawingDocument)
    oDrawingDoc.ActiveSheet.PartsLists(1).Export TempWorkbookFullName, kMicrosoftExcel, oDrawingDoc.DisplayName
End Sub

And if you don't need to combine lists into one sheet, comment out following codes or simply delete them :

    ' Combine worksheets into one sheet
    MsgBox "Start Step 2"
    CombineWorksheets oWorkbook

=====

Freeradical

 Hideo Yamada

[EMVC · Accepted solution]

Hello

Thank you , absoulte genius

[smichels]

Need help with this one.

I tried to use this example code and get a blank excel document and errors.

Please see attached

Thanks 

[smichels]

Disregard my last post.

The macro starts a blank excel workbook step1, step2 and end message works but nothing populates in excel work book. 

Any idea's would be helpful

Thanks