Drawings & BOM · 1.4
SolidWorks BOM to Round-Bar Planner Bridge
A SolidWorks VBA bridge that reads a drawing BOM, populates a round-bar nesting workbook, recalculates Excel, runs ProcessJob, and saves the result.
ENGINEERING CONTRIBUTION
Mapped BOM headers, preserved item numbers, populated the workbook table, and orchestrated Excel recalculation and processing.
Prerequisites
- SolidWorks VBA, a saved drawing with a BOM, and Microsoft Excel on Windows.
- Visible BOM headers ITEM NO., PART NUMBER, DESCRIPTION, MATERIAL, LENGTH and QTY.; optional extra-stock/end-cleanup columns.
- A locally configured XLSM template containing INPUT_PARTS / tblParts and public ProcessJob.
Additional setup
- Set TEMPLATE_PATH to a workbook containing INPUT_PARTS / tblParts and the public ProcessJob procedure.
SOURCE WALKTHROUGH
How the workflow fits together.
- 01
Locate the BOM
main checks a saved drawing and searches visible table headers, preferring the current sheet before other sheets.
- 02
Normalize usable rows
Blank, dash and N/A lengths are filtered out; length/fraction and quantity parsers coerce data for the workbook input table.
- 03
Copy and populate the workbook
The configured template is copied beside the drawing and INPUT_PARTS / tblParts is populated. An existing destination triggers a replace-or-reuse choice.
- 04
Run the Excel job and restore state
The macro automatically calls ProcessJob through Excel automation, calculates and saves. Cleanup restores Excel calculation/events/display state and the original drawing sheet where possible.
Output & model changes
- Copies or replaces a workbook after an explicit overwrite choice; populates its input table and saves it.
- Automatically executes the workbook's ProcessJob macro, which has its own dependencies and side effects.
- Temporarily changes Excel events, screen updating and calculation mode; may start an Excel instance.
CODE & ENTRY POINTS
Read the implementation.
Find a procedure, follow an API call or download the module for your SolidWorks setup.
BomToRoundBarNesting.bas
Drawing BOM extraction and header matching, length/quantity coercion, template copy, Excel table population and automatic ProcessJob invocation.
VBA · 996 lines
Entry points
API & integration calls
Attribute VB_Name = "modSolidWorksBomToRoundBarNesting"
Option Explicit
'===============================================================================
' SOLIDWORKS DRAWING BOM -> ROUND BAR NESTING WORKBOOK
'
' Workflow:
' 1. Run this macro from a saved SOLIDWORKS drawing.
' 2. The macro finds the BOM by its visible column headers.
' 3. It copies the Excel template into the drawing folder.
' 4. It writes the BOM into INPUT_PARTS / tblParts.
' 5. It runs the Excel macro ProcessJob and saves the workbook.
'
' Required BOM columns:
' ITEM NO. | PART NUMBER | DESCRIPTION | MATERIAL | LENGTH | QTY.
'
' Optional BOM columns:
' EXTRA STOCK | BAR END CLEANUP
'
' Revision 1.4:
' - Uses the verified stable V.04 workbook template.
' - Ignores BOM rows whose LENGTH is blank, dash, or N/A.
' - Fixes Excel runtime error 438 by calculating through Excel.Application.
' - PDF drag/drop is provided by the Excel task-pane add-in and does not alter this macro interface.
'===============================================================================
Private Const TEMPLATE_PATH As String = _
"C:\PublicUser\OneDrive - Employer Name Withheld\Desktop\ROUND_BAR_Nesting_Template_V.04_FIXED.xlsm"
' True -> <drawing name>_ROUND_BAR_NESTING.xlsm
' False -> keeps the template file name in the drawing folder
Private Const USE_DRAWING_NAME_FOR_OUTPUT As Boolean = True
Private Const OUTPUT_SUFFIX As String = "_ROUND_BAR_NESTING.xlsm"
Private Const INPUT_SHEET_NAME As String = "INPUT_PARTS"
Private Const INPUT_TABLE_NAME As String = "tblParts"
Private Const EXCEL_PROCESS_MACRO As String = "ProcessJob"
' SOLIDWORKS document type constant, defined locally so the macro does not
' depend on a separate swconst reference for this one value.
Private Const SW_DOC_DRAWING As Long = 3
' Excel constants for late-bound Excel automation.
Private Const XL_CALCULATION_MANUAL As Long = -4135
Private swApp As SldWorks.SldWorks
Public Sub main()
Dim swModel As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swSheet As SldWorks.Sheet
Dim drawingPath As String
Dim drawingFolder As String
Dim originalSheetName As String
Dim sourceSheetName As String
Dim sourceViewName As String
Dim destinationPath As String
Dim extractionWarnings As String
Dim bomData As Variant
Dim bomRowCount As Long
Dim xlApp As Object
Dim xlWb As Object
Dim createdExcel As Boolean
Dim excelStateCaptured As Boolean
Dim oldEnableEvents As Boolean
Dim oldScreenUpdating As Boolean
Dim oldCalculation As Variant
Dim completionMessage As String
Dim errorText As String
Dim savedErrorNumber As Long
Dim savedErrorDescription As String
Dim workflowStep As String
On Error GoTo FatalError
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then
Err.Raise vbObjectError + 1000, , _
"No SOLIDWORKS document is active. Open the drawing and run the macro again."
End If
If swModel.GetType <> SW_DOC_DRAWING Then
Err.Raise vbObjectError + 1001, , _
"The active SOLIDWORKS document is not a drawing."
End If
drawingPath = Trim$(swModel.GetPathName)
If Len(drawingPath) = 0 Then
Err.Raise vbObjectError + 1002, , _
"Save the SOLIDWORKS drawing before running this macro."
End If
Set swDraw = swModel
Set swSheet = swDraw.GetCurrentSheet
If Not swSheet Is Nothing Then originalSheetName = swSheet.GetName
drawingFolder = Left$(drawingPath, InStrRev(drawingPath, "\"))
workflowStep = "Reading and filtering the SOLIDWORKS BOM"
bomRowCount = ExtractBomFromDrawing( _
swDraw, originalSheetName, bomData, sourceSheetName, sourceViewName, extractionWarnings)
If bomRowCount <= 0 Then
Err.Raise vbObjectError + 1003, , _
"No usable bar/cut-list rows were found." & vbCrLf & vbCrLf & _
"The BOM must contain these visible headers:" & vbCrLf & _
"ITEM NO., PART NUMBER, DESCRIPTION, MATERIAL, LENGTH, and QTY." & _
vbCrLf & vbCrLf & _
"Rows with a blank, dash, or N/A LENGTH are intentionally ignored."
End If
workflowStep = "Copying the Excel nesting template"
destinationPath = BuildDestinationPath(drawingPath, drawingFolder)
PrepareDestinationWorkbook TEMPLATE_PATH, destinationPath
workflowStep = "Opening the copied Excel workbook"
Set xlApp = GetRunningExcelApplication()
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
createdExcel = True
End If
xlApp.Visible = True
Set xlWb = GetOpenWorkbookByFullName(xlApp, destinationPath)
If xlWb Is Nothing Then
Set xlWb = xlApp.Workbooks.Open(destinationPath)
End If
oldEnableEvents = xlApp.EnableEvents
oldScreenUpdating = xlApp.ScreenUpdating
oldCalculation = xlApp.Calculation
excelStateCaptured = True
xlApp.EnableEvents = False
xlApp.ScreenUpdating = False
xlApp.Calculation = XL_CALCULATION_MANUAL
workflowStep = "Writing filtered BOM rows to INPUT_PARTS"
PopulateInputTable xlWb, bomData, bomRowCount
' Restore Excel's normal operating state before running ProcessJob because
' the workbook's own VBA may rely on calculation, events, or screen updates.
xlApp.Calculation = oldCalculation
xlApp.EnableEvents = oldEnableEvents
xlApp.ScreenUpdating = oldScreenUpdating
excelStateCaptured = False
xlWb.Activate
' Workbook.Calculate is not supported by Excel's Workbook COM object and
' causes runtime error 438. Calculate through the Excel Application instead.
workflowStep = "Recalculating Excel before ProcessJob"
xlApp.Calculate
xlWb.Save
workflowStep = "Running the Excel ProcessJob macro"
RunExcelProcessJob xlApp, xlWb
workflowStep = "Saving the processed nesting workbook"
xlWb.Save
xlApp.Visible = True
If Len(originalSheetName) > 0 Then swDraw.ActivateSheet originalSheetName
completionMessage = CStr(bomRowCount) & " BOM row(s) copied and Process Job completed." & _
vbCrLf & vbCrLf & _
"BOM source: " & sourceSheetName
If Len(sourceViewName) > 0 Then
completionMessage = completionMessage & " / " & sourceViewName
End If
completionMessage = completionMessage & vbCrLf & _
"Workbook: " & destinationPath
If Len(extractionWarnings) > 0 Then
completionMessage = completionMessage & vbCrLf & vbCrLf & _
"Input warnings copied to Excel:" & vbCrLf & extractionWarnings
End If
MsgBox completionMessage, vbInformation, "Round Bar Nesting"
Exit Sub
FatalError:
savedErrorNumber = Err.Number
savedErrorDescription = Err.Description
On Error Resume Next
If excelStateCaptured And Not xlApp Is Nothing Then
xlApp.Calculation = oldCalculation
xlApp.EnableEvents = oldEnableEvents
xlApp.ScreenUpdating = oldScreenUpdating
End If
If Not xlApp Is Nothing Then xlApp.Visible = True
If Len(originalSheetName) > 0 And Not swDraw Is Nothing Then
swDraw.ActivateSheet originalSheetName
End If
' Do not close a populated workbook after an error; leaving it visible lets
' the user inspect the copied data. Quit only a newly created, empty Excel
' instance where no workbook was opened.
If createdExcel And xlWb Is Nothing And Not xlApp Is Nothing Then xlApp.Quit
errorText = "The BOM-to-nesting workflow did not complete." & vbCrLf & vbCrLf
If Len(workflowStep) > 0 Then
errorText = errorText & "Failed step: " & workflowStep & vbCrLf & vbCrLf
End If
errorText = errorText & _
"Error " & CStr(savedErrorNumber) & ": " & savedErrorDescription
If Not xlWb Is Nothing Then
errorText = errorText & vbCrLf & vbCrLf & _
"The Excel workbook has been left open for inspection."
End If
MsgBox errorText, vbCritical, "Round Bar Nesting"
End Sub
'===============================================================================
' SOLIDWORKS BOM EXTRACTION
'===============================================================================
Private Function ExtractBomFromDrawing( _
ByVal swDraw As SldWorks.DrawingDoc, _
ByVal originalSheetName As String, _
ByRef bomData As Variant, _
ByRef sourceSheetName As String, _
ByRef sourceViewName As String, _
ByRef warnings As String) As Long
Dim sheetNames As Variant
Dim sheetName As Variant
Dim candidateData As Variant
Dim candidateView As String
Dim candidateWarnings As String
Dim candidateCount As Long
' First scan the active sheet. This is the least surprising behavior when a
' drawing contains more than one BOM.
candidateCount = ExtractBestBomOnCurrentSheet( _
swDraw, candidateData, candidateView, candidateWarnings)
If candidateCount > 0 Then
bomData = candidateData
sourceSheetName = originalSheetName
sourceViewName = candidateView
warnings = candidateWarnings
ExtractBomFromDrawing = candidateCount
Exit Function
End If
' If the active sheet has no matching BOM, scan the remaining sheets.
sheetNames = swDraw.GetSheetNames
If IsArray(sheetNames) Then
For Each sheetName In sheetNames
If StrComp(CStr(sheetName), originalSheetName, vbTextCompare) <> 0 Then
If swDraw.ActivateSheet(CStr(sheetName)) Then
candidateData = Empty
candidateView = vbNullString
candidateWarnings = vbNullString
candidateCount = ExtractBestBomOnCurrentSheet( _
swDraw, candidateData, candidateView, candidateWarnings)
If candidateCount > 0 Then
bomData = candidateData
sourceSheetName = CStr(sheetName)
sourceViewName = candidateView
warnings = candidateWarnings
ExtractBomFromDrawing = candidateCount
If Len(originalSheetName) > 0 Then
swDraw.ActivateSheet originalSheetName
End If
Exit Function
End If
End If
End If
Next sheetName
End If
If Len(originalSheetName) > 0 Then swDraw.ActivateSheet originalSheetName
End Function
Private Function ExtractBestBomOnCurrentSheet( _
ByVal swDraw As SldWorks.DrawingDoc, _
ByRef bestData As Variant, _
ByRef bestViewName As String, _
ByRef bestWarnings As String) As Long
Dim swView As SldWorks.View
Dim swTable As SldWorks.TableAnnotation
Dim candidateData As Variant
Dim candidateWarnings As String
Dim candidateCount As Long
Dim bestCount As Long
Set swView = swDraw.GetFirstView
Do While Not swView Is Nothing
Set swTable = swView.GetFirstTableAnnotation
Do While Not swTable Is Nothing
candidateData = Empty
candidateWarnings = vbNullString
candidateCount = ReadBomTable(swTable, candidateData, candidateWarnings)
If candidateCount > bestCount Then
bestCount = candidateCount
bestData = candidateData
bestViewName = swView.GetName2
bestWarnings = candidateWarnings
End If
Set swTable = swTable.GetNext
Loop
Set swView = swView.GetNextView
Loop
ExtractBestBomOnCurrentSheet = bestCount
End Function
Private Function ReadBomTable( _
ByVal swTable As SldWorks.TableAnnotation, _
ByRef outputData As Variant, _
ByRef warnings As String) As Long
Dim headerRow As Long
Dim headerMap() As Long
Dim rowIndex As Long
Dim fieldIndex As Long
Dim rowCount As Long
Dim rows As Collection
Dim rowValues As Variant
Dim finalData() As Variant
Dim currentRow As Variant
Dim lengthParsed As Boolean
Dim quantityParsed As Boolean
ReDim headerMap(1 To 8)
If Not FindRequiredHeaderRow(swTable, headerRow, headerMap) Then Exit Function
Set rows = New Collection
For rowIndex = 0 To swTable.RowCount - 1
If rowIndex <> headerRow Then
If Not IsTableRowHidden(swTable, rowIndex) Then
ReDim rowValues(1 To 8)
For fieldIndex = 1 To 8
If headerMap(fieldIndex) >= 0 Then
rowValues(fieldIndex) = CleanCellText( _
GetTableCellText(swTable, rowIndex, headerMap(fieldIndex)))
Else
rowValues(fieldIndex) = vbNullString
End If
Next fieldIndex
If IsPotentialBomDataRow(rowValues) Then
If Not RowLooksLikeHeader(rowValues) Then
If Not RowLooksLikeTotal(rowValues) Then
' Detailed weldment BOMs can include the top-level weldment,
' machined parts, and waterjet parts. Only rows with a real
' LENGTH belong in the bar-nesting input.
If HasPopulatedLengthValue(CStr(rowValues(5))) Then
rowValues(5) = CoerceLengthForExcel( _
CStr(rowValues(5)), lengthParsed)
rowValues(6) = CoerceQuantityForExcel( _
CStr(rowValues(6)), quantityParsed)
If Not lengthParsed Then
AppendWarning warnings, _
"BOM row " & CStr(rowIndex + 1) & _
": LENGTH was copied as text (" & CStr(rowValues(5)) & ")."
End If
If Len(Trim$(CStr(rowValues(6)))) = 0 Then
AppendWarning warnings, _
"BOM row " & CStr(rowIndex + 1) & ": QTY. is blank."
ElseIf Not quantityParsed Then
AppendWarning warnings, _
"BOM row " & CStr(rowIndex + 1) & _
": QTY. was copied as text (" & CStr(rowValues(6)) & ")."
End If
rows.Add rowValues
End If
End If
End If
End If
End If
End If
Next rowIndex
rowCount = rows.Count
If rowCount = 0 Then Exit Function
ReDim finalData(1 To rowCount, 1 To 8)
For rowIndex = 1 To rowCount
currentRow = rows(rowIndex)
For fieldIndex = 1 To 8
finalData(rowIndex, fieldIndex) = currentRow(fieldIndex)
Next fieldIndex
Next rowIndex
outputData = finalData
ReadBomTable = rowCount
End Function
Private Function FindRequiredHeaderRow( _
ByVal swTable As SldWorks.TableAnnotation, _
ByRef headerRow As Long, _
ByRef headerMap() As Long) As Boolean
Dim rowIndex As Long
Dim columnIndex As Long
Dim fieldIndex As Long
Dim detectedField As Long
Dim cellText As String
For rowIndex = 0 To swTable.RowCount - 1
For fieldIndex = 1 To 8
headerMap(fieldIndex) = -1
Next fieldIndex
For columnIndex = 0 To swTable.ColumnCount - 1
cellText = GetTableCellText(swTable, rowIndex, columnIndex)
detectedField = HeaderFieldNumber(cellText)
If detectedField > 0 Then
If headerMap(detectedField) < 0 Then
headerMap(detectedField) = columnIndex
End If
End If
Next columnIndex
If headerMap(1) >= 0 And _
headerMap(2) >= 0 And _
headerMap(3) >= 0 And _
headerMap(4) >= 0 And _
headerMap(5) >= 0 And _
headerMap(6) >= 0 Then
headerRow = rowIndex
FindRequiredHeaderRow = True
Exit Function
End If
Next rowIndex
End Function
Private Function HeaderFieldNumber(ByVal headerText As String) As Long
Dim normalized As String
normalized = NormalizeHeaderText(headerText)
Select Case normalized
Case "ITEM", "ITEM NO", "ITEM NUMBER", "FIND NO", "FIND NUMBER"
HeaderFieldNumber = 1
Case "PART", "PART NO", "PART NUMBER"
HeaderFieldNumber = 2
Case "DESCRIPTION", "DESC"
HeaderFieldNumber = 3
Case "MATERIAL", "MATL", "MAT L"
HeaderFieldNumber = 4
Case "LENGTH", "LENGTH IN", "CUT LENGTH", "CUT LENGTH IN", _
"FINISH LENGTH", "FINISHED LENGTH"
HeaderFieldNumber = 5
Case "QTY", "QUANTITY", "QTY REQUIRED", "REQUIRED QTY"
HeaderFieldNumber = 6
Case "EXTRA STOCK", "EXTRA STOCK IN", "EXTRA LENGTH"
HeaderFieldNumber = 7
Case "BAR END CLEANUP", "BAR END CLEAN UP", "END CLEANUP", _
"END CLEAN UP"
HeaderFieldNumber = 8
End Select
End Function
Private Function GetTableCellText( _
ByVal swTable As SldWorks.TableAnnotation, _
ByVal rowIndex As Long, _
ByVal columnIndex As Long) As String
On Error Resume Next
GetTableCellText = CStr(swTable.DisplayedText2(rowIndex, columnIndex, True))
If Err.Number <> 0 Then
Err.Clear
GetTableCellText = CStr(swTable.Text2(rowIndex, columnIndex, True))
End If
On Error GoTo 0
End Function
Private Function IsTableRowHidden( _
ByVal swTable As SldWorks.TableAnnotation, _
ByVal rowIndex As Long) As Boolean
On Error Resume Next
IsTableRowHidden = CBool(swTable.RowHidden(rowIndex))
On Error GoTo 0
End Function
Private Function IsPotentialBomDataRow(ByVal rowValues As Variant) As Boolean
' A table title can occupy the ITEM NO. column in a merged cell. Requiring
' content in at least one of the other core fields avoids importing titles.
IsPotentialBomDataRow = _
Len(Trim$(CStr(rowValues(2)))) > 0 Or _
Len(Trim$(CStr(rowValues(3)))) > 0 Or _
Len(Trim$(CStr(rowValues(4)))) > 0 Or _
Len(Trim$(CStr(rowValues(5)))) > 0 Or _
Len(Trim$(CStr(rowValues(6)))) > 0
End Function
Private Function HasPopulatedLengthValue(ByVal rawValue As String) As Boolean
Dim normalized As String
normalized = UCase$(CleanCellText(rawValue))
normalized = Replace(normalized, ChrW(&H2013), "-")
normalized = Replace(normalized, ChrW(&H2014), "-")
Select Case normalized
Case vbNullString, "-", "--", "N/A", "NA", "NONE"
HasPopulatedLengthValue = False
Case Else
HasPopulatedLengthValue = True
End Select
End Function
Private Function RowLooksLikeHeader(ByVal rowValues As Variant) As Boolean
Dim matches As Long
Dim fieldIndex As Long
For fieldIndex = 1 To 6
If HeaderFieldNumber(CStr(rowValues(fieldIndex))) = fieldIndex Then
matches = matches + 1
End If
Next fieldIndex
RowLooksLikeHeader = (matches >= 4)
End Function
Private Function RowLooksLikeTotal(ByVal rowValues As Variant) As Boolean
Dim itemText As String
Dim partText As String
Dim descriptionText As String
itemText = UCase$(Trim$(CStr(rowValues(1))))
partText = UCase$(Trim$(CStr(rowValues(2))))
descriptionText = UCase$(Trim$(CStr(rowValues(3))))
RowLooksLikeTotal = _
(itemText = "TOTAL" Or Left$(itemText, 6) = "TOTAL ") Or _
(partText = "TOTAL" Or Left$(partText, 6) = "TOTAL ") Or _
(descriptionText = "TOTAL" Or Left$(descriptionText, 6) = "TOTAL ")
End Function
'===============================================================================
' EXCEL WORKBOOK CREATION AND POPULATION
'===============================================================================
Private Function BuildDestinationPath( _
ByVal drawingPath As String, _
ByVal drawingFolder As String) As String
Dim fso As Object
Dim fileName As String
Set fso = CreateObject("Scripting.FileSystemObject")
If USE_DRAWING_NAME_FOR_OUTPUT Then
fileName = SanitizeFileName(fso.GetBaseName(drawingPath)) & OUTPUT_SUFFIX
Else
fileName = fso.GetFileName(TEMPLATE_PATH)
End If
BuildDestinationPath = drawingFolder & fileName
End Function
Private Sub PrepareDestinationWorkbook( _
ByVal sourcePath As String, _
ByVal destinationPath As String)
Dim fso As Object
Dim overwriteChoice As VbMsgBoxResult
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FileExists(sourcePath) Then
Err.Raise vbObjectError + 1100, , _
"Excel template not found:" & vbCrLf & sourcePath
End If
If StrComp(sourcePath, destinationPath, vbTextCompare) = 0 Then
Err.Raise vbObjectError + 1101, , _
"The template and destination paths are the same. " & _
"Keep USE_DRAWING_NAME_FOR_OUTPUT set to True or move the template."
End If
If fso.FileExists(destinationPath) Then
overwriteChoice = MsgBox( _
"A nesting workbook already exists:" & vbCrLf & _
destinationPath & vbCrLf & vbCrLf & _
"Yes = replace it with a fresh template" & vbCrLf & _
"No = reuse and repopulate the existing workbook" & vbCrLf & _
"Cancel = stop", _
vbYesNoCancel + vbQuestion, _
"Existing Nesting Workbook")
If overwriteChoice = vbCancel Then
Err.Raise vbObjectError + 1102, , "Operation cancelled by user."
ElseIf overwriteChoice = vbNo Then
Exit Sub
End If
End If
On Error GoTo CopyFailed
fso.CopyFile sourcePath, destinationPath, True
Exit Sub
CopyFailed:
Err.Raise vbObjectError + 1103, , _
"The Excel template could not be copied to the drawing folder." & vbCrLf & _
"Close any workbook using the destination file and verify folder permissions." & _
vbCrLf & vbCrLf & _
"Destination: " & destinationPath & vbCrLf & _
"Windows error: " & Err.Description
End Sub
Private Function GetRunningExcelApplication() As Object
On Error Resume Next
Set GetRunningExcelApplication = GetObject(, "Excel.Application")
On Error GoTo 0
End Function
Private Function GetOpenWorkbookByFullName( _
ByVal xlApp As Object, _
ByVal fullName As String) As Object
Dim wb As Object
For Each wb In xlApp.Workbooks
If StrComp(CStr(wb.FullName), fullName, vbTextCompare) = 0 Then
Set GetOpenWorkbookByFullName = wb
Exit Function
End If
Next wb
End Function
Private Sub PopulateInputTable( _
ByVal xlWb As Object, _
ByVal bomData As Variant, _
ByVal bomRowCount As Long)
Dim ws As Object
Dim inputTable As Object
Dim targetRange As Object
Dim inputColumn As Object
Dim headerRow As Long
Dim firstColumn As Long
Dim lastColumn As Long
Dim existingDataRows As Long
Dim requiredDataRows As Long
Dim columnIndex As Long
Dim maxPartRows As Long
On Error Resume Next
Set ws = xlWb.Worksheets(INPUT_SHEET_NAME)
On Error GoTo 0
If ws Is Nothing Then
Err.Raise vbObjectError + 1200, , _
"Worksheet '" & INPUT_SHEET_NAME & "' was not found in the copied workbook."
End If
On Error Resume Next
Set inputTable = ws.ListObjects(INPUT_TABLE_NAME)
On Error GoTo 0
If inputTable Is Nothing Then
Err.Raise vbObjectError + 1201, , _
"Excel table '" & INPUT_TABLE_NAME & "' was not found on " & _
INPUT_SHEET_NAME & "."
End If
On Error Resume Next
maxPartRows = CLng(xlWb.Names("MaxPartRows").RefersToRange.Value2)
On Error GoTo 0
If maxPartRows > 0 And bomRowCount > maxPartRows Then
Err.Raise vbObjectError + 1202, , _
"The BOM contains " & CStr(bomRowCount) & " rows, but the nesting " & _
"workbook is configured for a maximum of " & CStr(maxPartRows) & "."
End If
headerRow = inputTable.HeaderRowRange.Row
firstColumn = inputTable.Range.Column
lastColumn = firstColumn + inputTable.ListColumns.Count - 1
existingDataRows = inputTable.ListRows.Count
requiredDataRows = existingDataRows
If requiredDataRows < bomRowCount Then requiredDataRows = bomRowCount
If requiredDataRows < 1 Then requiredDataRows = 1
If requiredDataRows <> existingDataRows Then
inputTable.Resize ws.Range( _
ws.Cells(headerRow, firstColumn), _
ws.Cells(headerRow + requiredDataRows, lastColumn))
End If
' Clear only the eight editable input columns. Formula/helper columns I:N are
' preserved, and Excel extends their calculated-column formulas when needed.
For columnIndex = 1 To 8
Set inputColumn = inputTable.ListColumns(columnIndex)
If Not inputColumn.DataBodyRange Is Nothing Then
inputColumn.DataBodyRange.ClearContents
End If
Next columnIndex
Set targetRange = ws.Cells(headerRow + 1, firstColumn).Resize(bomRowCount, 8)
' Preserve item and part numbers exactly as displayed, including leading zeroes.
targetRange.Columns(1).NumberFormat = "@"
targetRange.Columns(2).NumberFormat = "@"
targetRange.Columns(3).NumberFormat = "@"
targetRange.Columns(4).NumberFormat = "@"
targetRange.Columns(5).NumberFormat = "0.000"
targetRange.Columns(6).NumberFormat = "0"
targetRange.Value2 = bomData
ws.Activate
targetRange.Cells(1, 1).Select
End Sub
Private Sub RunExcelProcessJob(ByVal xlApp As Object, ByVal xlWb As Object)
Dim qualifiedMacroName As String
Dim savedErrorNumber As Long
Dim savedErrorDescription As String
qualifiedMacroName = "'" & Replace(CStr(xlWb.Name), "'", "''") & _
"'!" & EXCEL_PROCESS_MACRO
On Error GoTo ProcessFailed
xlApp.Run qualifiedMacroName
Exit Sub
ProcessFailed:
savedErrorNumber = Err.Number
savedErrorDescription = Err.Description
Err.Raise vbObjectError + 1300, , _
"The BOM was copied into Excel, but the workbook macro '" & _
EXCEL_PROCESS_MACRO & "' could not be run." & vbCrLf & vbCrLf & _
"Confirm that Excel macros are enabled, the file is trusted/unblocked, " & _
"and the template still contains the public ProcessJob procedure." & _
vbCrLf & vbCrLf & _
"Excel error " & CStr(savedErrorNumber) & ": " & savedErrorDescription
End Sub
'===============================================================================
' DATA CLEANING AND NUMERIC CONVERSION
'===============================================================================
Private Function CleanCellText(ByVal value As String) As String
Dim cleaned As String
cleaned = Replace(value, vbCr, " ")
cleaned = Replace(cleaned, vbLf, " ")
cleaned = Replace(cleaned, Chr$(160), " ")
CleanCellText = Trim$(CollapseSpaces(cleaned))
End Function
Private Function NormalizeHeaderText(ByVal value As String) As String
Dim normalized As String
normalized = UCase$(CleanCellText(value))
normalized = Replace(normalized, ".", " ")
normalized = Replace(normalized, "/", " ")
normalized = Replace(normalized, "\", " ")
normalized = Replace(normalized, "-", " ")
normalized = Replace(normalized, "_", " ")
normalized = Replace(normalized, "#", " ")
normalized = Replace(normalized, "(", " ")
normalized = Replace(normalized, ")", " ")
normalized = Replace(normalized, ":", " ")
NormalizeHeaderText = Trim$(CollapseSpaces(normalized))
End Function
Private Function CollapseSpaces(ByVal value As String) As String
Dim result As String
result = value
Do While InStr(result, " ") > 0
result = Replace(result, " ", " ")
Loop
CollapseSpaces = result
End Function
Private Function CoerceLengthForExcel( _
ByVal rawValue As String, _
ByRef parsedSuccessfully As Boolean) As Variant
Dim inches As Double
If Len(Trim$(rawValue)) = 0 Then
parsedSuccessfully = False
CoerceLengthForExcel = Empty
ElseIf TryParseLengthInches(rawValue, inches) Then
parsedSuccessfully = True
CoerceLengthForExcel = inches
Else
parsedSuccessfully = False
CoerceLengthForExcel = rawValue
End If
End Function
Private Function CoerceQuantityForExcel( _
ByVal rawValue As String, _
ByRef parsedSuccessfully As Boolean) As Variant
Dim cleaned As String
Dim numericValue As Double
cleaned = UCase$(Trim$(rawValue))
cleaned = Replace(cleaned, "PCS", "")
cleaned = Replace(cleaned, "PC", "")
cleaned = Replace(cleaned, "EA", "")
cleaned = Trim$(cleaned)
If Len(cleaned) = 0 Then
parsedSuccessfully = False
CoerceQuantityForExcel = Empty
ElseIf IsNumeric(cleaned) Then
numericValue = CDbl(cleaned)
parsedSuccessfully = True
CoerceQuantityForExcel = numericValue
Else
parsedSuccessfully = False
CoerceQuantityForExcel = rawValue
End If
End Function
Private Function TryParseLengthInches( _
ByVal rawValue As String, _
ByRef resultInches As Double) As Boolean
Dim cleaned As String
Dim isMillimetres As Boolean
Dim slashPosition As Long
Dim separatorPosition As Long
Dim wholeText As String
Dim fractionText As String
Dim fractionValue As Double
Dim numericValue As Double
cleaned = UCase$(Trim$(rawValue))
cleaned = Replace(cleaned, ChrW(&HBC), " 1/4")
cleaned = Replace(cleaned, ChrW(&HBD), " 1/2")
cleaned = Replace(cleaned, ChrW(&HBE), " 3/4")
cleaned = Replace(cleaned, ChrW(&H215B), " 1/8")
cleaned = Replace(cleaned, ChrW(&H215C), " 3/8")
cleaned = Replace(cleaned, ChrW(&H215D), " 5/8")
cleaned = Replace(cleaned, ChrW(&H215E), " 7/8")
cleaned = Replace(cleaned, Chr$(34), "")
cleaned = Replace(cleaned, ",", "")
If InStr(1, cleaned, "MM", vbTextCompare) > 0 Then
isMillimetres = True
cleaned = Replace(cleaned, "MILLIMETRES", "")
cleaned = Replace(cleaned, "MILLIMETERS", "")
cleaned = Replace(cleaned, "MM", "")
Else
cleaned = Replace(cleaned, "INCHES", "")
cleaned = Replace(cleaned, "INCH", "")
If Right$(Trim$(cleaned), 2) = "IN" Then
cleaned = Left$(Trim$(cleaned), Len(Trim$(cleaned)) - 2)
End If
End If
cleaned = Trim$(CollapseSpaces(cleaned))
Do While InStr(cleaned, " /") > 0
cleaned = Replace(cleaned, " /", "/")
Loop
Do While InStr(cleaned, "/ ") > 0
cleaned = Replace(cleaned, "/ ", "/")
Loop
If Len(cleaned) = 0 Then Exit Function
If IsNumeric(cleaned) Then
numericValue = CDbl(cleaned)
Else
slashPosition = InStrRev(cleaned, "/")
If slashPosition = 0 Then Exit Function
separatorPosition = InStrRev(Left$(cleaned, slashPosition - 1), " ")
If separatorPosition = 0 Then
separatorPosition = InStrRev(Left$(cleaned, slashPosition - 1), "-")
End If
If separatorPosition > 0 Then
wholeText = Trim$(Left$(cleaned, separatorPosition - 1))
fractionText = Trim$(Mid$(cleaned, separatorPosition + 1))
If Not IsNumeric(wholeText) Then Exit Function
If Not TryParseSimpleFraction(fractionText, fractionValue) Then Exit Function
numericValue = CDbl(wholeText) + fractionValue
Else
If Not TryParseSimpleFraction(cleaned, numericValue) Then Exit Function
End If
End If
If isMillimetres Then numericValue = numericValue / 25.4
resultInches = numericValue
TryParseLengthInches = True
End Function
Private Function TryParseSimpleFraction( _
ByVal fractionText As String, _
ByRef fractionValue As Double) As Boolean
Dim slashPosition As Long
Dim numeratorText As String
Dim denominatorText As String
Dim denominator As Double
slashPosition = InStr(1, fractionText, "/")
If slashPosition <= 1 Then Exit Function
numeratorText = Trim$(Left$(fractionText, slashPosition - 1))
denominatorText = Trim$(Mid$(fractionText, slashPosition + 1))
If Not IsNumeric(numeratorText) Then Exit Function
If Not IsNumeric(denominatorText) Then Exit Function
denominator = CDbl(denominatorText)
If denominator = 0 Then Exit Function
fractionValue = CDbl(numeratorText) / denominator
TryParseSimpleFraction = True
End Function
Private Sub AppendWarning(ByRef warningText As String, ByVal newWarning As String)
If Len(warningText) > 0 Then warningText = warningText & vbCrLf
warningText = warningText & newWarning
End Sub
Private Function SanitizeFileName(ByVal fileName As String) As String
Dim invalidCharacters As Variant
Dim invalidCharacter As Variant
Dim result As String
result = fileName
invalidCharacters = Array("<", ">", ":", Chr$(34), "/", "\", "|", "?", "*")
For Each invalidCharacter In invalidCharacters
result = Replace(result, CStr(invalidCharacter), "_")
Next invalidCharacter
SanitizeFileName = Trim$(result)
End Function
Procedure index · 27 declarations
File checksum
SHA-256: 3a11a2f47012db1dcd9849a5a4075619173f5b07a267e649cb83f44925f41166