'Macro to parse part quantity out of an exported
'assembly navigator view.
'Assumes part number is in column A and
'component name is in column B.
'Quantity will be placed in column C.
Option Explicit
Dim strPartNumber As String
Dim strQuantity As String
Sub Macro1()
Attribute Macro1.VB_Description = "Parses quantity information from a UG assembly navigator that has been exported to spreadsheet."
Attribute Macro1.VB_ProcData.VB_Invoke_Func = "q\n14"
Call ParseQuantity
Call AssemblyLevel
End Sub
Private Sub ParseQuantity()
Dim i As Long
Dim j As Long
'insert quantity column
'change this as needed
Columns("C:C").Select
Selection.Insert Shift:=xlToRight
Range("C1:C1").Select
ActiveCell.Value = "Quantity"
Columns("C:C").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
.NumberFormat = "General"
End With
Columns("C:C").EntireColumn.AutoFit
'select first cell in part number column
'change this as needed
Range("A2:A2").Select
'loop through cells that are not empty
'when macro encounters an empty cell it stops
Do Until ActiveCell.Value = ""
strPartNumber = ActiveCell.Text
i = InStr(1, strPartNumber, " x ")
If i = 0 Then
'string not found, quantity = 1
ActiveCell.Offset(0, 2).Activate
ActiveCell.Value = "1"
ActiveCell.Offset(0, -2).Activate
Else
'string found, quantity > 1
j = Len(strPartNumber)
strQuantity = Right(strPartNumber, j - i)
'strip off first 2 characters of quantity string - "x "
strQuantity = Right(strQuantity, Len(strQuantity) - 2)
'strip off last character of part number string (a space)
strPartNumber = Left(strPartNumber, i - 1)
'record part number with quantity stripped off the end
ActiveCell.Value = strPartNumber
'move cell over a column and record quantity
ActiveCell.Offset(0, 2).Activate
ActiveCell.Value = strQuantity
'move cell back to partnumber column
ActiveCell.Offset(0, -2).Activate
End If
'move active cell down 1 row
ActiveCell.Offset(1, 0).Activate
Loop
End Sub
Private Sub AssemblyLevel()
Dim strAssemblyLevel As String
Dim strPartNumber As String
Dim strSpaces As String
Dim i As Long
'insert quantity column
'change this as needed
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Range("A1:A1").Select
ActiveCell.Value = "Assembly Level"
Columns("A:A").Select
With Selection.Font
.Name = "Courier New"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Columns("A:A").Select
Selection.NumberFormat = "@"
Range("A1").Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Columns("A:A").EntireColumn.AutoFit
Range("B2:B2").Select
'loop through cells that are not empty
'when macro encounters an empty cell it stops
Do Until ActiveCell.Value = ""
strPartNumber = ActiveCell.Text
For i = 1 To Len(strPartNumber)
strSpaces = Mid(strPartNumber, i, 1)
If strSpaces <> " " Then
If i = 1 Then
strAssemblyLevel = "1"
Exit For
Else
i = i - 1
strAssemblyLevel = String(i / 4, ".")
strAssemblyLevel = strAssemblyLevel & CStr(i / 4 + 1)
Exit For
End If
End If
Next i
'move active cell to first column to record assembly level
ActiveCell.Offset(0, -1).Activate
ActiveCell.Value = strAssemblyLevel
'move active cell down a row and over a column to get next part number
ActiveCell.Offset(1, 1).Activate
'MsgBox strAssemblyLevel & " " & strPartNumber, vbOKOnly
Loop
Range("A1:A1").Select
End Sub
