Suggest me improvement in this script. make this industrial grade: - Option Explicit

' =============================================================================
' Author:        Alicia Technologies LLP
' Created On:    06-12-2024 03:21 PM
' Description:   Processes multiple tables within an Excel worksheet by splitting
'                component positions into separate rows in a new processed sheet.
'                Enhances data normalization for Bill of Materials (BOM).
' =============================================================================

Sub SplitComponentsMultipleTablesCorrected()
    On Error GoTo ErrorHandler  ' Global error handler for runtime errors.
    
    ' =============================================================================
    ' Variable Declarations
    ' =============================================================================
    Dim sourceWorksheet As Worksheet
    Dim processedWorksheet As Worksheet
    Dim processedSheetName As String
    Dim totalRows As Long
    Dim currentRow As Long
    Dim targetRow As Long
    Dim partRefHeader As String
    Dim qtyHeader As String
    Dim colMapping As Object
    Dim headerRow As Long
    
    ' =============================================================================
    ' Performance Optimization: Disable screen updating and automatic calculations
    ' =============================================================================
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' Set the name for the processed sheet
    processedSheetName = "ProcessedBillOfMaterial"
    
    ' =============================================================================
    ' Select the source worksheet
    ' =============================================================================
    Set sourceWorksheet = SelectSheetByIndex()
    
    ' Validate the selected worksheet
    If sourceWorksheet Is Nothing Then
        MsgBox "No worksheet selected. Operation canceled.", vbExclamation
        GoTo Cleanup
    End If
    
    ' =============================================================================
    ' Prompt user for header names
    ' =============================================================================
    partRefHeader = InputBox("Enter the exact header name of the 'Part Reference' column:", _
                             "Part Reference Header", "Part Reference")
    If Trim(partRefHeader) = "" Then
        MsgBox "You must specify a valid Part Reference header.", vbExclamation
        GoTo Cleanup
    End If
    
    qtyHeader = InputBox("Enter the exact header name of the 'Quantity' column (leave blank if none):", _
                        "Quantity Header", "Quantity")
    
    ' =============================================================================
    ' Validate data in the source worksheet
    ' =============================================================================
    If sourceWorksheet.UsedRange Is Nothing Then
        MsgBox "The selected worksheet contains no data.", vbExclamation
        GoTo Cleanup
    End If
    
    totalRows = sourceWorksheet.UsedRange.Rows.Count
    If totalRows = 0 Then
        MsgBox "The selected worksheet contains no data.", vbExclamation
        GoTo Cleanup
    End If
    
    currentRow = 1
    targetRow = 1  ' Start from row 1 in the processed sheet
    
    ' =============================================================================
    ' Setup the processed worksheet
    ' =============================================================================
    Set processedWorksheet = SetupProcessedSheet(processedSheetName)
    If processedWorksheet Is Nothing Then
        MsgBox "Could not create or access the processed sheet.", vbExclamation
        GoTo Cleanup
    End If
    
    ' =============================================================================
    ' Loop through all rows to find and process each table
    ' =============================================================================
    Do While currentRow <= totalRows
        Set colMapping = FindNextTable(sourceWorksheet, currentRow, totalRows, headerRow, partRefHeader)
        
        If Not colMapping Is Nothing Then
            ' Process the identified table
            ProcessTable sourceWorksheet, processedWorksheet, currentRow, totalRows, _
                        headerRow, colMapping, targetRow, partRefHeader, qtyHeader
        Else
            ' No more tables found
            Exit Do
        End If
    Loop
    
    ' =============================================================================
    ' Finalize the processed worksheet
    ' =============================================================================
    On Error Resume Next
    processedWorksheet.Columns.AutoFit
    On Error GoTo ErrorHandler
    
    ' Notify the user of successful completion
    MsgBox "Component positions have been split into separate rows on the '" & processedSheetName & "' sheet.", _
           vbInformation, "Process Complete"
    
Cleanup:
    ' Re-enable settings changed for performance optimization
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Exit Sub

ErrorHandler:
    ' Global Error Handler
    MsgBox "An unexpected error occurred: " & Err.Description, vbCritical, "Error"
    Resume Cleanup
End Sub

' =============================================================================
' Function: SetupProcessedSheet
' Purpose : Creates or replaces the processed worksheet where normalized data will
'           be stored.
' =============================================================================
Function SetupProcessedSheet(processedSheetName As String) As Worksheet
    On Error GoTo SetupErrorHandler
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    
    ' =============================================================================
    ' Delete existing processed sheet if it exists
    ' =============================================================================
    Application.DisplayAlerts = False  ' Suppress confirmation dialogs
    On Error Resume Next
    wb.Sheets(processedSheetName).Delete
    On Error GoTo 0
    Application.DisplayAlerts = True  ' Re-enable alerts
    
    ' =============================================================================
    ' Create a new processed sheet
    ' =============================================================================
    Set SetupProcessedSheet = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
    SetupProcessedSheet.Name = processedSheetName
    Exit Function

SetupErrorHandler:
    MsgBox "Error setting up the processed sheet: " & Err.Description, vbExclamation, "Setup Error"
    Set SetupProcessedSheet = Nothing
End Function

' =============================================================================
' Function: FindNextTable
' Purpose : Identifies the next table's header row starting from the current row
'           and returns a mapping of column headers to their respective indices.
' =============================================================================
Function FindNextTable(sourceWs As Worksheet, ByRef currentRow As Long, _
                       totalRows As Long, ByRef headerRow As Long, _
                       partRefHeader As String) As Object
    On Error GoTo FindNextTableError
    Dim i As Long
    Dim colMapping As Object
    
    For i = currentRow To totalRows
        Set colMapping = IsHeaderRow(sourceWs, i, partRefHeader)
        If Not colMapping Is Nothing Then
            headerRow = i
            currentRow = i + 1  ' Move to the row after the header
            Set FindNextTable = colMapping
            Exit Function
        End If
    Next i
    
    Set FindNextTable = Nothing
    Exit Function

FindNextTableError:
    MsgBox "Error finding next table: " & Err.Description, vbExclamation, "Find Table Error"
    Set FindNextTable = Nothing
End Function

' =============================================================================
' Subroutine: ProcessTable
' Purpose     : Processes a single table by copying and splitting data rows
' =============================================================================
Sub ProcessTable(sourceWs As Worksheet, processedWs As Worksheet, _
                 ByRef currentRow As Long, totalRows As Long, _
                 headerRow As Long, colMapping As Object, _
                 ByRef targetRow As Long, partRefHeader As String, _
                 qtyHeader As String)
    On Error GoTo TableErrorHandler
    Dim initialColumn As Long
    Dim lastNonEmptyColumn As Long
    Dim headers As Variant
    Dim partRefCol As Long
    Dim qtyCol As Long
    
    ' Determine table columns
    initialColumn = sourceWs.Cells(headerRow, 1).Column
    lastNonEmptyColumn = sourceWs.Cells(headerRow, sourceWs.Columns.Count).End(xlToLeft).Column
    
    ' Read headers
    headers = sourceWs.Range(sourceWs.Cells(headerRow, initialColumn), _
                             sourceWs.Cells(headerRow, lastNonEmptyColumn)).Value
    
    ' Identify columns
    If Not colMapping.Exists(LCase(Trim(partRefHeader))) Then
        MsgBox "The specified Part Reference header '" & partRefHeader & _
               "' was not found in the header row at " & headerRow & ".", vbCritical, "Header Not Found"
        Exit Sub
    Else
        partRefCol = colMapping(LCase(Trim(partRefHeader)))
    End If
    
    If Trim(qtyHeader) <> "" Then
        If colMapping.Exists(LCase(Trim(qtyHeader))) Then
            qtyCol = colMapping(LCase(Trim(qtyHeader)))
        Else
            MsgBox "The specified Quantity header '" & qtyHeader & "' was not found. Proceeding without Quantity.", _
                   vbExclamation, "Quantity Header Not Found"
            qtyCol = 0
        End If
    Else
        qtyCol = 0
    End If
    
    ' Write headers to processed sheet if first table
    If targetRow = 1 Then
        WriteHeaders processedWs, headers, initialColumn, lastNonEmptyColumn, targetRow
    End If
    
    ' Process table rows
    Do While currentRow <= totalRows
        If IsEmptyRow(sourceWs, currentRow) Then
            currentRow = currentRow + 1
            Exit Do
        End If
        
        ' Check if next row is a header row (next table)
        If Not IsHeaderRow(sourceWs, currentRow, partRefHeader) Is Nothing Then
            Exit Do
        End If
        
        ' Process data row
        ProcessDataRow sourceWs, processedWs, currentRow, targetRow, _
                      initialColumn, lastNonEmptyColumn, partRefCol, qtyCol
                      
        currentRow = currentRow + 1
    Loop
    
    Exit Sub

TableErrorHandler:
    MsgBox "Error processing table starting at header row " & headerRow & ": " & Err.Description, _
           vbExclamation, "Table Processing Error"
End Sub

' =============================================================================
' Subroutine: WriteHeaders
' Purpose     : Writes the header row to the processed worksheet
' =============================================================================
Sub WriteHeaders(processedWs As Worksheet, headers As Variant, _
                 initialColumn As Long, lastNonEmptyColumn As Long, _
                 ByRef targetRow As Long)
    On Error GoTo WriteHeadersError
    processedWs.Range(processedWs.Cells(targetRow, initialColumn), _
                     processedWs.Cells(targetRow, lastNonEmptyColumn)).Value = headers
    
    targetRow = targetRow + 1
    Exit Sub

WriteHeadersError:
    MsgBox "Error writing headers: " & Err.Description, vbExclamation, "Header Writing Error"
End Sub

' =============================================================================
' Subroutine: ProcessDataRow
' Purpose     : Processes a single data row by splitting part references and
'               copying the data to the processed worksheet
' =============================================================================
Sub ProcessDataRow(sourceWs As Worksheet, processedWs As Worksheet, _
                   currentRow As Long, ByRef targetRow As Long, _
                   initialColumn As Long, lastNonEmptyColumn As Long, _
                   partRefCol As Long, qtyCol As Long)
    On Error GoTo DataRowError
    Dim partReferences As String
    Dim trimmedRefs() As String
    Dim idx As Long
    Dim isFirstRef As Boolean
    
    ' Retrieve and clean the "Part Reference" value from the current row
    partReferences = Trim(Application.Clean(sourceWs.Cells(currentRow, partRefCol).Value))
    
    ' Proceed only if "Part Reference" is not empty
    If partReferences <> "" Then
        ' Split the "Part Reference" into individual references
        trimmedRefs = SplitAndTrimPartReferences(partReferences)
        
        ' Check if any references were found after splitting
        If UBound(trimmedRefs) >= LBound(trimmedRefs) Then
            ' Iterate through each part reference and copy data accordingly
            For idx = LBound(trimmedRefs) To UBound(trimmedRefs)
                isFirstRef = (idx = LBound(trimmedRefs))
                
                CopyDataToProcessedSheet sourceWs, processedWs, currentRow, targetRow, _
                                         initialColumn, lastNonEmptyColumn, trimmedRefs(idx), _
                                         partRefCol, qtyCol, isFirstRef
                                         
                ' Increment target row after copying
                targetRow = targetRow + 1
            Next idx
        Else
            ' No valid references found after splitting
            Debug.Print "Row " & currentRow & ": No valid references found after splitting."
        End If
    Else
        ' "Part Reference" is empty or invalid
        Debug.Print "Row " & currentRow & ": 'Part Reference' is empty or invalid."
    End If
    
    Exit Sub

DataRowError:
    MsgBox "Error processing data row " & currentRow & ": " & Err.Description, vbExclamation, "Data Row Error"
End Sub

' =============================================================================
' Function: SplitAndTrimPartReferences
' Purpose : Splits the "Part Reference" string by a delimiter and trims each reference
' =============================================================================
Function SplitAndTrimPartReferences(partReferences As String) As Variant
    On Error Resume Next
    Dim refArray() As String
    Dim trimmedRefs() As String
    Dim idx As Long
    
    ' Split the part references by comma (adjust delimiter if necessary)
    refArray = Split(partReferences, ",")
    
    ' Handle cases where splitting results in no elements
    If UBound(refArray) < LBound(refArray) Then
        ReDim trimmedRefs(0 To 0)
        trimmedRefs(0) = partReferences
        SplitAndTrimPartReferences = trimmedRefs
        Exit Function
    End If
    
    ' Initialize the trimmed references array
    ReDim trimmedRefs(LBound(refArray) To UBound(refArray))
    For idx = LBound(refArray) To UBound(refArray)
        trimmedRefs(idx) = Trim(refArray(idx))
    Next idx
    
    SplitAndTrimPartReferences = trimmedRefs
End Function

' =============================================================================
' Subroutine: CopyDataToProcessedSheet
' Purpose     : Copies data from the source worksheet to the processed worksheet,
'               updating the "Part Reference" and optionally handling the "Quantity"
' =============================================================================
Sub CopyDataToProcessedSheet(sourceWs As Worksheet, processedWs As Worksheet, _
                             currentRow As Long, targetRow As Long, _
                             initialColumn As Long, lastNonEmptyColumn As Long, _
                             trimmedRef As String, partRefCol As Long, _
                             qtyCol As Long, isFirstRef As Boolean)
    On Error GoTo CopyError
    ' Copy the entire row's data to the processed sheet
    processedWs.Range(processedWs.Cells(targetRow, initialColumn), _
                      processedWs.Cells(targetRow, lastNonEmptyColumn)).Value = _
                      sourceWs.Range(sourceWs.Cells(currentRow, initialColumn), _
                                     sourceWs.Cells(currentRow, lastNonEmptyColumn)).Value
                     
    ' Update the "Part Reference" column with the individual reference
    processedWs.Cells(targetRow, partRefCol).Value = trimmedRef
    
    ' Optionally blank out the "Quantity" column for subsequent references
    If Not isFirstRef And qtyCol > 0 Then
        processedWs.Cells(targetRow, qtyCol).Value = ""  ' Blank out quantity
    End If
    
    Exit Sub

CopyError:
    MsgBox "Error copying data to processed sheet at row " & targetRow & ": " & Err.Description, _
           vbExclamation, "Copy Error"
End Sub

' =============================================================================
' Function: IsHeaderRow
' Purpose : Determines if a given row is a header row by checking for the presence
'           of the specified "Part Reference" header. Returns a mapping of headers
'           to their column indices if true; otherwise, returns Nothing.
' =============================================================================
Function IsHeaderRow(sourceWs As Worksheet, rowNum As Long, _
                   partRefHeader As String) As Object
    On Error GoTo HeaderError
    Dim colIndex As Long
    Dim headerText As String
    Dim headerFound As Boolean
    Dim colMapping As Object
    
    headerFound = False
    Set colMapping = CreateObject("Scripting.Dictionary")
    
    ' Iterate through each column in the row to identify headers
    For colIndex = 1 To sourceWs.UsedRange.Columns.Count
        headerText = LCase(Trim(CStr(sourceWs.Cells(rowNum, colIndex).Value)))
        If headerText <> "" Then
            colMapping(headerText) = colIndex
            If LCase(partRefHeader) = headerText Then
                headerFound = True
            End If
        End If
    Next colIndex
    
    ' Determine if the current row is a header row based on the presence of the
    ' specified "Part Reference" header
    If headerFound Then
        Set IsHeaderRow = colMapping  ' Return the column mapping dictionary
    Else
        Set IsHeaderRow = Nothing  ' Not a header row
    End If
    
    Exit Function

HeaderError:
    MsgBox "Error checking if row " & rowNum & " is a header row: " & Err.Description, _
           vbExclamation, "Header Row Error"
    Set IsHeaderRow = Nothing
End Function

' =============================================================================
' Function: IsEmptyRow
' Purpose : Checks if a given row in the worksheet is empty (no data).
' =============================================================================
Function IsEmptyRow(sourceWs As Worksheet, rowNum As Long) As Boolean
    On Error Resume Next
    IsEmptyRow = (Application.WorksheetFunction.CountA(sourceWs.Rows(rowNum)) = 0)
End Function

' =============================================================================
' Function: SelectSheetByIndex
' Purpose : Prompts the user to select a worksheet by its index number from the
'           active workbook. Returns the selected worksheet or Nothing if canceled.
' =============================================================================
Function SelectSheetByIndex() As Worksheet
    On Error GoTo SelectErrorHandler
    Dim wb As Workbook
    Dim i As Integer
    Dim sheetList As String
    Dim sheetIndex As Variant
    Dim isValidIndex As Boolean

    Set wb = ActiveWorkbook
    
    ' Validate that an active workbook exists
    If wb Is Nothing Then
        MsgBox "No active workbook found.", vbExclamation, "Workbook Not Found"
        Set SelectSheetByIndex = Nothing
        Exit Function
    End If

    ' Build a list of available sheets for user selection
    sheetList = "Available Sheets:" & vbCrLf
    For i = 1 To wb.Sheets.Count
        sheetList = sheetList & i & ": " & wb.Sheets(i).Name & vbCrLf
    Next i

    ' Highlight the currently active sheet
    If Not ActiveSheet Is Nothing Then
        sheetList = sheetList & vbCrLf & "Currently active sheet: " & ActiveSheet.Name
    End If

    ' Prompt the user to enter the index number of the desired sheet
    Do
        sheetIndex = Application.InputBox( _
            Prompt:=sheetList & vbCrLf & "Enter the index number of the sheet to select:", _
            Title:="Select Sheet", Type:=1)  ' Type:=1 ensures numeric input

        ' Check if the user canceled the input
        If sheetIndex = False Then
            Set SelectSheetByIndex = Nothing
            Exit Function
        End If

        ' Validate the user input
        isValidIndex = (IsNumeric(sheetIndex) And sheetIndex >= 1 And sheetIndex <= wb.Sheets.Count)
        If isValidIndex Then Exit Do  ' Valid index entered

        ' Inform the user of invalid input and prompt again
        MsgBox "Invalid input. Please enter a valid index number corresponding to a sheet.", _
               vbExclamation, "Invalid Input"
    Loop

    ' Return the selected worksheet based on the validated index
    Set SelectSheetByIndex = wb.Sheets(CLng(sheetIndex))
    Exit Function

SelectErrorHandler:
    MsgBox "Error selecting sheet by index: " & Err.Description, vbExclamation, "Selection Error"
    Set SelectSheetByIndex = Nothing
End Function