Hi All. I'm a relatively newbie to VBA code but I have managed to patch together a macro that when run from an assembly document populates an excel document with the QTY, STOCK NUMBER and DESCRIPTION of the parts. This works well.
I now just need to tidy it up by EXCLUDING some parts from the list. I need to exclude andy ietsm that DO NOT have a Stock Number and also EXCLUDE all items where the Stock Number starts with 01000 or larger. I'm thinking I need to either put this into the below code which does the occurence count and stuff, or as I select the range at the end of the macro, somehow run a filter to delete these rows. B Currently i'm just putting up a message box telling the document creator to manually delete these rows. Below is the code I am using so far (I will also accept any comments about the code as it is-remember I have pieced this together from various other sources and have little VBA experience ).
Sub AssyBOM2Excel()
Dim oAssDoc As AssemblyDocument
Set oAssDoc = ThisApplication.ActiveDocument
If oAssDoc.DocumentType <> kAssemblyDocumentObject Then
MsgBox "The Active document must be an 'Assembly'!"
Exit Sub
End If
Dim oDocs As DocumentsEnumerator
Set oDocs = oAssDoc.AllReferencedDocuments
Dim oDoc As Document
Dim row As Integer
Dim excel_app As Excel.Application
app2check = "Excel.Application"
If IsApplicationRunning(app2check) = True Then
Set excel_app = Excel.Application
Else
Set excel_app = CreateObject("Excel.Application")
End If
excel_app.Visible = True
excel_app.Workbooks.Add
With excel_app
.Columns("A:A").ColumnWidth = 20
.Range("A1").Select
Selection.Font.Bold = True
With Selection.Font
.Name = "Calibri"
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
.ActiveCell.FormulaR1C1 = "ASSEMBLY 'BOUGHT' PARTS LIST"
.Columns("A:A").ColumnWidth = 20
.Range("A2").Select
Selection.Font.Bold = True
With Selection.Font
.Color = -6279056
.TintAndShade = 0
End With
.ActiveCell.FormulaR1C1 = "If the Assembly No. below does not end in -00000 then the QTY's shown may be wrong as this list has been generated from a sub-assembly!"
.Columns("A:A").ColumnWidth = 20
.Range("A3").Select
Selection.Font.Bold = True
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
.ActiveCell.FormulaR1C1 = "This list shows only BOUGHT items and DOES NOT include Sheet Metal or Plasma items."
.Range("A5").Select
.ActiveCell.FormulaR1C1 = "ASSEMBLY No. - " & Left(oAssDoc.DisplayName, Len(oAssDoc.DisplayName) - 4)
.Range("A6").Select
.ActiveCell.FormulaR1C1 = "Stock Code"
.Columns("B:B").ColumnWidth = 10
.Range("B6").Select
.ActiveCell.FormulaR1C1 = "Qty"
.Columns("C:C").ColumnWidth = 105
.Range("C6").Select
.ActiveCell.FormulaR1C1 = "Description"
row = 6
For Each oDoc In oDocs
'revFlag = 0
Dim oOccs As ComponentOccurrencesEnumerator
Set oOccs = oAssDoc.ComponentDefinition.Occurrences.AllReferencedOccurrences(oDoc)
Dim oPropSets As PropertySets
Set oPropSets = oDoc.PropertySets
Dim oProp1 As Property
Set oProp1 = oPropSets.Item("{32853F0F-3444-11d1-9E93-0060B03C1CA6}").ItemByPropId(kStockNumberDesignTrackingProperties)
oStockNumber = oProp1.Value
Dim oProp2 As Property
Set oProp2 = oPropSets.Item("{32853F0F-3444-11d1-9E93-0060B03C1CA6}").ItemByPropId(kDescriptionDesignTrackingProperties)
oDescription = oProp2.Value
If oOccs.Count <> 0 Then
row = row + 1
With excel_app
.Range("A" & Format$(row)).Select
.ActiveCell.FormulaR1C1 = oStockNumber
.Range("B" & Format$(row)).Select
.ActiveCell.FormulaR1C1 = oOccs.Count
.Range("C" & Format$(row)).Select
.ActiveCell.FormulaR1C1 = oDescription
End With
End If
Next
'With excel_app
'sortRange = "A7:C" & row
'.Range(sortRange).Select
'Sleep 500
'.Selection.Sort Key1:=Range("A7"), Order1:=xlAscending
'End With
'add blue to stock/qty/desc row
With Worksheets("Sheet1").Cells
With .FormatConditions
.Delete
.Add Type:=xlExpression, Formula1:="=ROW()=6"
End With
.FormatConditions(1).Interior.ColorIndex = 33
End With
With Worksheets("Sheet1").Cells
N = 7
For Each VisRow In Selection.Resize(, 1).SpecialCells(xlCellTypeVisible)
N = N + 1
If N Mod 2 = 0 Then
VisRow.EntireRow.Interior.ColorIndex = 15
End If
Next VisRow
End With
With excel_app
sortRange = "A7:C" & row
.Range(sortRange).Select
Sleep 500
.Selection.Sort Key1:=Range("A7"), Order1:=xlAscending
End With
End With
If oAssDoc.DocumentType = kAssemblyDocumentObject Then
MsgBox "Before printing the Parts List delete all rows with blank STOCK CODE numbers and those with STOCK CODE numbers larger than 00999-99999", vbExclamation
'Exit Sub
End If
End Sub
