32 KiB
32 KiB
VBA 模組原始碼
來源：全機型_日報表.xlsm
提取工具：olevba 0.60.2
提取時間：2026-04-07
Module19.bas - NT()
Function NT(Number As Integer) As String
NT = Split(Cells(1, Number).Address, "$")(1)
End Function
Module7.bas - ra()
Function ra(inputText As String) As String
Dim regEx As Object
Dim matches As Object
Set regEx = CreateObject("VBScript.RegExp")
With regEx
.pattern = "[A-Z0-9-]{6,25}"
.Global = True
End With
Set matches = regEx.Execute(inputText)
If matches.Count > 0 Then
ra = matches(0).Value
Else
ra = "NO"
End If
End Function
Module5.bas - A()
Sub A()
Call B
Call Q
End Sub
Module6.bas - B()
Sub B()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim wsFocest As Worksheet, wsBOM As Worksheet, wsOutput As Worksheet, wsUnmatched As Worksheet
Dim lastRowF As Long, lastRowB As Long, lastRowO As Long, lastRowU As Long
Dim i As Long, j As Long, k As Long, col As Long
Dim keyPart As String, material As String, usage As Double
Dim lic As Double, focestCol1 As String, focestCol2 As String
Dim weekValues(1 To 56) As Double
Dim dictBOM As Object, dictUnmatched As Object
Dim materialData As Variant
Dim key As Variant
Set dictBOM = CreateObject("Scripting.Dictionary")
Set dictUnmatched = CreateObject("Scripting.Dictionary")
' Set worksheets
Set wsFocest = ThisWorkbook.Sheets("FCST")
Set wsBOM = ThisWorkbook.Sheets("BOM")
' Create new worksheets for output
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Sheets("Output").Delete
ThisWorkbook.Sheets("Unmatched").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set wsOutput = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsOutput.Name = "Output"
Set wsUnmatched = ThisWorkbook.Sheets.Add(After:=wsOutput)
wsUnmatched.Name = "Unmatched"
' Phase 1: Read BOM data into dictionary
lastRowB = wsBOM.Cells(wsBOM.Rows.Count, "A").End(xlUp).Row
Dim bomData As Variant
bomData = wsBOM.Range("A2:C" & lastRowB).Value
For i = 1 To UBound(bomData, 1)
keyPart = Trim(bomData(i, 1) & "")
material = Trim(bomData(i, 2) & "")
' Safe handling of usage value
If IsNumeric(bomData(i, 3)) Then
usage = CDbl(bomData(i, 3))
Else
usage = 0
End If
If keyPart <> "" And material <> "" Then
If Not dictBOM.exists(keyPart) Then
dictBOM.Add keyPart, New Collection
End If
dictBOM(keyPart).Add Array(material, usage)
End If
Next i
' Phase 2: Process Focest data - only process rows with BOM matches
lastRowF = wsFocest.Cells(wsFocest.Rows.Count, "A").End(xlUp).Row
Dim focestData As Variant
focestData = wsFocest.Range("A2:BJ" & lastRowF).Value ' Columns A to BJ (A, B + 56 weeks)
' Pre-calculate output data size
Dim outputRowCount As Long
outputRowCount = 0
For i = 1 To UBound(focestData, 1)
keyPart = Trim(focestData(i, 1) & "")
If keyPart <> "" And dictBOM.exists(keyPart) Then
outputRowCount = outputRowCount + dictBOM(keyPart).Count
End If
Next i
' Prepare output array
Dim outputData() As Variant
ReDim outputData(1 To outputRowCount, 1 To 60) ' 4 fixed columns + 56 week columns
lastRowO = 0
For i = 1 To UBound(focestData, 1)
keyPart = Trim(focestData(i, 1) & "")
If keyPart = "" Then GoTo NextFocestRow
' Only process rows with BOM matches
If dictBOM.exists(keyPart) Then
focestCol1 = focestData(i, 1) & ""
focestCol2 = focestData(i, 2) & ""
' Safe handling of LIC value
If IsNumeric(focestData(i, 2)) Then
lic = CDbl(focestData(i, 2))
Else
lic = 0
End If
' Extract week values with error handling
For j = 1 To 56
If IsNumeric(focestData(i, j + 2)) Then
weekValues(j) = CDbl(focestData(i, j + 2))
Else
weekValues(j) = 0
End If
Next j
' Process matching BOM items
For k = 1 To dictBOM(keyPart).Count
materialData = dictBOM(keyPart)(k)
material = materialData(0)
usage = materialData(1)
lastRowO = lastRowO + 1
outputData(lastRowO, 1) = focestCol1
outputData(lastRowO, 2) = focestCol2
outputData(lastRowO, 3) = material
outputData(lastRowO, 4) = usage
For col = 1 To 56
outputData(lastRowO, col + 4) = weekValues(col) * lic * usage
Next col
Next k
End If
NextFocestRow:
Next i
' Phase 3: Separately process Focest rows without BOM matches
For i = 1 To UBound(focestData, 1)
keyPart = Trim(focestData(i, 1) & "")
If keyPart <> "" And Not dictBOM.exists(keyPart) Then
If Not dictUnmatched.exists(keyPart) Then
dictUnmatched.Add keyPart, True
End If
End If
Next i
' Batch write output data
If outputRowCount > 0 Then
wsOutput.Range("A2").Resize(outputRowCount, 60).Value = outputData
End If
' Generate unmatched sheet
wsUnmatched.Cells(1, 1).Value = "Unmatched Key Part Numbers"
If dictUnmatched.Count > 0 Then
Dim unmatchedData() As Variant
ReDim unmatchedData(1 To dictUnmatched.Count, 1 To 1)
i = 0
For Each key In dictUnmatched.Keys
i = i + 1
unmatchedData(i, 1) = key
Next key
wsUnmatched.Range("A2").Resize(dictUnmatched.Count, 1).Value = unmatchedData
End If
' Set headers
wsOutput.Cells(1, 1).Value = "Focest Col1"
wsOutput.Cells(1, 2).Value = "Focest Col2"
wsOutput.Cells(1, 3).Value = "Material Number"
wsOutput.Cells(1, 4).Value = "BOM Usage"
For col = 1 To 56
wsOutput.Cells(1, col + 4).Value = "Week" & col
Next col
' Auto-fit columns
wsOutput.Columns.AutoFit
wsUnmatched.Columns.AutoFit
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
MsgBox "Processing completed! " & outputRowCount & " rows generated in Output sheet. " & _
dictUnmatched.Count & " unmatched items found."
End Sub
Module3.bas - Q()
Sub Q()
' Define variables
Dim wsSource As Worksheet, wsDest As Worksheet
Dim pvtCache As PivotCache
Dim pvtTable As PivotTable
Dim lastRow As Long
Dim SourceDataRange As Range
Dim i As Long
Dim fieldName As String
Dim startTime As Double
Dim dataField As PivotField
' Start timing execution
startTime = Timer
' Disable Excel features for performance optimization
OptimizeVBA True
On Error GoTo ErrorHandler
' Check if source worksheet exists
If Not WorksheetExists("Output") Then
MsgBox "Source worksheet 'Output' not found!", vbCritical
GoTo CleanUp
End If
' Set reference to source worksheet
Set wsSource = ThisWorkbook.Worksheets("Output")
' Delete destination worksheet if it already exists
If WorksheetExists("Cutout") Then
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("Cutout").Delete
Application.DisplayAlerts = True
End If
' Remove any existing pivot table with the same name
RemovePivotTable "WeeklySummaryPivot"
' Create new worksheet for the pivot table
Set wsDest = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsDest.Name = "Cutout"
' Find the last row with data in source worksheet - MORE ROBUST METHOD
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
If lastRow = 1 And wsSource.Cells(1, 1).Value = "" Then lastRow = 0
' Verify there is sufficient data
If lastRow < 2 Then
MsgBox "Insufficient data in source worksheet!", vbExclamation
GoTo CleanUp
End If
' Define source data range
Set SourceDataRange = wsSource.Range("A1:BH" & lastRow)
' Create pivot cache from source data
Set pvtCache = ThisWorkbook.PivotCaches.Create( _
SourceType:=xlDatabase, _
SourceData:=SourceDataRange.Address(ReferenceStyle:=xlR1C1, External:=True))
Set pvtTable = pvtCache.CreatePivotTable( _
TableDestination:=wsDest.Range("A3"), _
tableName:="WeeklySummaryPivot")
With pvtTable
.ManualUpdate = True
.RowAxisLayout xlTabularRow
' Add row field - Material Number (Column C)
.PivotFields(wsSource.Cells(1, 3).Value).Orientation = xlRowField
' Add data fields (columns E to BH) - WITH PERFORMANCE CHECK
For i = 5 To 60
fieldName = wsSource.Cells(1, i).Value
' Only add field if it has a name and is likely numeric (avoid text fields for sum)
If fieldName <> "" Then
On Error Resume Next
Set dataField = .PivotFields(fieldName)
If Err.Number = 0 Then
With dataField
.Orientation = xlDataField
.Function = xlSum
.NumberFormat = "#,##0"
' Only rename if not already renamed
If InStr(1, .Caption, "Sum of", vbTextCompare) = 0 Then
.Caption = "Sum of " & fieldName
End If
End With
Else
Err.Clear
End If
On Error GoTo ErrorHandler
End If
Next i
' Apply formatting
.ShowTableStyleRowStripes = True
On Error Resume Next
.TableStyle2 = "PivotStyleMedium9"
If Err.Number <> 0 Then
.TableStyle1 = "PivotStyleMedium9"
Err.Clear
End If
On Error GoTo ErrorHandler
.ManualUpdate = False
End With
' Add title and timestamp
With wsDest
.Range("A1").Value = "Weekly Summary Report"
.Range("A1").Font.Bold = True
.Range("A1").Font.Size = 14
.Range("A2").Value = "Generated: " & Now()
.Range("A2").Font.Italic = True
End With
' Auto-fit columns carefully for large datasets
Application.ScreenUpdating = False
wsDest.UsedRange.Columns.AutoFit
Application.ScreenUpdating = True
' Success message
MsgBox "Pivot table created successfully in " & Format(Timer - startTime, "0.00") & _
" seconds! Location: Worksheet " & wsDest.Name, vbInformation
CleanUp:
OptimizeVBA False
Set pvtTable = Nothing
Set pvtCache = Nothing
Set SourceDataRange = Nothing
Set wsSource = Nothing
Set wsDest = Nothing
Exit Sub
ErrorHandler:
MsgBox "Error " & Err.Number & ": " & Err.Description & vbCrLf & _
"Please ensure your data in 'Output' sheet is correctly formatted.", vbCritical
Resume CleanUp
End Sub
' Helper function: Optimize VBA performance
Sub OptimizeVBA(Optimize As Boolean)
With Application
If Optimize Then
.ScreenUpdating = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
.EnableEvents = False
.StatusBar = "Processing... Please wait"
Else
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
.EnableEvents = True
.StatusBar = False
End If
End With
End Sub
' Helper function: Check if worksheet exists
Function WorksheetExists(sheetName As String) As Boolean
On Error Resume Next
WorksheetExists = Not ThisWorkbook.Sheets(sheetName) Is Nothing
On Error GoTo 0
End Function
' Helper function: Remove pivot table by name (FIXED For Each issue)
Sub RemovePivotTable(tableName As String)
Dim ws As Worksheet
Dim pt As PivotTable
On Error Resume Next
For Each ws In ThisWorkbook.Worksheets
' CRITICAL FIX: Check if the worksheet has any pivot tables before trying to access one by name
If ws.PivotTables.Count > 0 Then
Set pt = ws.PivotTables(tableName)
If Not pt Is Nothing Then
pt.TableRange2.Clear
Exit For
End If
End If
Next ws
On Error GoTo 0
End Sub
Module20.bas - W()
Sub W()
' =========================================================================
' USER CONFIGURATION AREA - Modify parameters below
' =========================================================================
' Data source settings
Const SOURCE_SHEET As String = "KCB" ' Source worksheet name
Const PIVOT_SHEET_NAME As String = "MaterialSummary" ' Output pivot table sheet name
Const HEADER_ROW As Long = 1 ' Header row number
' Custom column settings
Dim CUSTOM_COLUMNS As Variant
CUSTOM_COLUMNS = Array("B", "C", "D", "E", "F", "G", "H", "I", "J") ' Columns to include
' Pivot table field settings
Const ROW_FIELD_COLUMN As String = "B" ' Row field (row labels) column
Dim DATA_FIELDS As Variant
DATA_FIELDS = Array("C", "D", "E", "F", "G", "H") ' Data field columns to summarize
' Performance optimization settings
Const USE_ARRAY_METHOD As Boolean = False ' Disable array method to avoid 1004 errors
' Output settings
Const SHOW_PERFORMANCE_STATS As Boolean = True ' Show performance statistics
Const AUTO_ADJUST_COLUMNS As Boolean = True ' Auto-adjust column widths
' =========================================================================
' MAIN PROGRAM - Code below generally doesn't need modification
' =========================================================================
Dim startTime As Double
If SHOW_PERFORMANCE_STATS Then startTime = Timer
Dim wsData As Worksheet, wsPivot As Worksheet
Dim rngData As Range
Dim lastRow As Long, lastCol As Long
' Performance optimization settings
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.StatusBar = "Preparing data..."
On Error GoTo ErrorHandler
' Check if source sheet exists
If Not WorksheetExists(SOURCE_SHEET) Then
MsgBox "Source worksheet '" & SOURCE_SHEET & "' not found!", vbExclamation
GoTo CleanUp
End If
' Set source worksheet
Set wsData = ThisWorkbook.Worksheets(SOURCE_SHEET)
' Get data range
With wsData
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
lastCol = .Cells(HEADER_ROW, .Columns.Count).End(xlToLeft).Column
If lastRow <= HEADER_ROW Then
MsgBox "No data found in worksheet!", vbExclamation
GoTo CleanUp
End If
Application.StatusBar = "Reading data (" & lastRow & " rows)..."
' Build data range
Set rngData = BuildSafeRange(wsData, HEADER_ROW, lastRow, CUSTOM_COLUMNS)
If rngData Is Nothing Then
MsgBox "Failed to create data range. Please check column references.", vbExclamation
GoTo CleanUp
End If
If rngData.Rows.Count <= 1 Then
MsgBox "No data rows found after applying column filters.", vbExclamation
GoTo CleanUp
End If
End With
' Delete existing worksheet
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Worksheets(PIVOT_SHEET_NAME).Delete
On Error GoTo ErrorHandler
Application.DisplayAlerts = True
' Create new worksheet
Application.StatusBar = "Creating pivot table..."
Set wsPivot = ThisWorkbook.Worksheets.Add
wsPivot.Name = PIVOT_SHEET_NAME
' Create pivot table (now uses DATA_FIELDS setting)
CreatePivotTableWithDataFields wsPivot, rngData, ROW_FIELD_COLUMN, DATA_FIELDS, wsData, HEADER_ROW
' Apply formatting
Application.StatusBar = "Applying formatting..."
With wsPivot
.Range("A1").Value = "Material Summary"
.Range("A1").Font.Bold = True
.Range("A1").Font.Size = 14
If AUTO_ADJUST_COLUMNS Then
.Columns.AutoFit
End If
.Range("A2").Value = "Created: " & Now()
.Range("A2").Font.Italic = True
.Range("A2").Font.Color = RGB(100, 100, 100)
End With
' Show results
Application.StatusBar = False
If SHOW_PERFORMANCE_STATS Then
Dim endTime As Double, elapsedTime As Double
endTime = Timer
elapsedTime = endTime - startTime
MsgBox "Pivot table created successfully!" & vbCrLf & _
"Data rows: " & (lastRow - HEADER_ROW) & vbCrLf & _
"Columns included: " & (UBound(CUSTOM_COLUMNS) - LBound(CUSTOM_COLUMNS) + 1) & vbCrLf & _
"Data fields: " & Join(DATA_FIELDS, ", ") & vbCrLf & _
"Processing time: " & Format(elapsedTime, "0.00") & " seconds", vbInformation
Else
MsgBox "Pivot table created successfully!", vbInformation
End If
CleanUp:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.StatusBar = False
Exit Sub
ErrorHandler:
MsgBox "Error " & Err.Number & ": " & Err.Description & vbCrLf & _
"Please check your configuration settings and data structure.", vbCritical
GoTo CleanUp
End Sub
' =========================================================================
' Fixed pivot table creation function - Now correctly uses DATA_FIELDS setting
' =========================================================================
Sub CreatePivotTableWithDataFields(wsPivot As Worksheet, rngData As Range, rowFieldCol As String, dataFields As Variant, wsData As Worksheet, headerRow As Long)
' Purpose: Create pivot table using configured data fields
On Error GoTo ErrorHandler
Dim pc As PivotCache, pt As PivotTable
Dim i As Long, fieldIndex As Long
Dim rowFieldTitle As String, dataFieldTitle As String
Dim colIndex As Long
' Validate data range
If rngData Is Nothing Then
MsgBox "Data range is empty. Cannot create pivot table.", vbExclamation
Exit Sub
End If
If rngData.Rows.Count <= 1 Then
MsgBox "Not enough data rows for pivot table.", vbExclamation
Exit Sub
End If
' Create pivot cache
Set pc = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rngData)
' Create pivot table
Set pt = pc.CreatePivotTable(TableDestination:=wsPivot.Range("A3"), tableName:="CustomPivot")
With pt
' Add row field (using configured row field column)
colIndex = GetColumnIndex(rowFieldCol)
If colIndex > 0 Then
rowFieldTitle = wsData.Cells(headerRow, colIndex).Value
.PivotFields(rowFieldTitle).Orientation = xlRowField
Else
' If row field is invalid, use first column as default row field
.PivotFields(1).Orientation = xlRowField
End If
' Add data fields (using configured data fields)
For i = LBound(dataFields) To UBound(dataFields)
colIndex = GetColumnIndex(dataFields(i))
If colIndex > 0 Then
dataFieldTitle = wsData.Cells(headerRow, colIndex).Value
On Error Resume Next ' Skip fields that cannot be added
.AddDataField .PivotFields(dataFieldTitle), "Sum of " & dataFieldTitle, xlSum
On Error GoTo ErrorHandler
End If
Next i
' If no data fields were successfully added, add all numeric fields as fallback
If .dataFields.Count = 0 Then
MsgBox "Configured data fields are invalid. Adding all numeric fields.", vbExclamation
For i = 2 To .PivotFields.Count
On Error Resume Next
.AddDataField .PivotFields(i), "Sum of " & .PivotFields(i).Name, xlSum
On Error GoTo ErrorHandler
Next i
End If
' Apply style
On Error Resume Next
.TableStyle2 = "PivotStyleLight16"
.RowAxisLayout xlTabularRow
On Error GoTo ErrorHandler
End With
Exit Sub
ErrorHandler:
MsgBox "Error creating pivot table: " & Err.Description, vbExclamation
End Sub
' =========================================================================
' Helper functions
' =========================================================================
Function BuildSafeRange(ws As Worksheet, headerRow As Long, lastRow As Long, customCols As Variant) As Range
' Purpose: Safely build data range
On Error GoTo ErrorHandler
Dim firstCol As Long, lastCol As Long
Dim colIndex As Long, i As Long
' Validate custom column references
For i = LBound(customCols) To UBound(customCols)
colIndex = GetColumnIndex(customCols(i))
If colIndex < 1 Or colIndex > ws.Columns.Count Then
MsgBox "Invalid column reference: " & customCols(i), vbExclamation
Set BuildSafeRange = Nothing
Exit Function
End If
Next i
firstCol = GetColumnIndex(customCols(LBound(customCols)))
lastCol = GetColumnIndex(customCols(UBound(customCols)))
If headerRow > lastRow Then
MsgBox "Header row is after last data row!", vbExclamation
Set BuildSafeRange = Nothing
Exit Function
End If
Set BuildSafeRange = ws.Range(ws.Cells(headerRow, firstCol), ws.Cells(lastRow, lastCol))
If BuildSafeRange Is Nothing Then
MsgBox "Failed to create data range.", vbExclamation
Exit Function
End If
Exit Function
ErrorHandler:
MsgBox "Error in BuildSafeRange: " & Err.Description, vbExclamation
Set BuildSafeRange = Nothing
End Function
Function GetColumnIndex(col As Variant) As Long
' Purpose: Convert column letter to column index
On Error GoTo ErrorHandler
If VarType(col) = vbString Then
GetColumnIndex = Range(col & "1").Column
Else
GetColumnIndex = col
End If
Exit Function
ErrorHandler:
GetColumnIndex = 0
End Function
Function WorksheetExists(sheetName As String) As Boolean
' Purpose: Check if worksheet exists
On Error Resume Next
WorksheetExists = Not ThisWorkbook.Worksheets(sheetName) Is Nothing
On Error GoTo 0
End Function
' =========================================================================
' Diagnostic tools
' =========================================================================
Sub CheckDataFields()
' Purpose: Check if data field configuration is correct
Dim wsData As Worksheet
Dim dataField As Variant
Dim colIndex As Long
Dim result As String
Set wsData = ThisWorkbook.Worksheets("KCB")
result = "Data Fields Check:" & vbCrLf & vbCrLf
For Each dataField In Array("C", "E") ' Using configured DATA_FIELDS
colIndex = GetColumnIndex(dataField)
If colIndex > 0 Then
result = result & "Column " & dataField & ": Valid" & vbCrLf & _
" Index: " & colIndex & vbCrLf & _
" Title: '" & wsData.Cells(1, colIndex).Value & "'" & vbCrLf & vbCrLf
Else
result = result & "Column " & dataField & ": Invalid" & vbCrLf & vbCrLf
End If
Next dataField
MsgBox result, vbInformation, "Data Fields Check"
End Sub
' =========================================================================
' Simple version - Use if above code still has issues
' =========================================================================
Sub SimplePivotTable()
' Very simple version to avoid 1004 errors
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
On Error GoTo ErrorHandler
Dim wsData As Worksheet, wsPivot As Worksheet
Dim rngData As Range
Dim lastRow As Long
' Configuration - modify as needed
Const SOURCE_SHEET As String = "KCB"
Const PIVOT_SHEET_NAME As String = "SimpleSummary"
' Check if source exists
If Not WorksheetExists(SOURCE_SHEET) Then
MsgBox "Worksheet '" & SOURCE_SHEET & "' not found!", vbExclamation
GoTo CleanUp
End If
Set wsData = ThisWorkbook.Worksheets(SOURCE_SHEET)
' Find last row in column B (material column)
lastRow = wsData.Cells(wsData.Rows.Count, "B").End(xlUp).Row
If lastRow <= 1 Then
MsgBox "No data found!", vbExclamation
GoTo CleanUp
End If
' Use simple range (columns B to I)
Set rngData = wsData.Range("B1:I" & lastRow)
' Delete existing sheet
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Worksheets(PIVOT_SHEET_NAME).Delete
On Error GoTo ErrorHandler
Application.DisplayAlerts = True
' Create pivot table using simple method
Set wsPivot = ThisWorkbook.Worksheets.Add
wsPivot.Name = PIVOT_SHEET_NAME
' This method is less likely to cause 1004 errors
wsPivot.Activate
Set rngData = wsData.Range("B1:I" & lastRow)
' Use PivotTableWizard to create pivot table
Set pt = wsPivot.PivotTableWizard(SourceType:=xlDatabase, _
SourceData:=rngData, _
TableDestination:=wsPivot.Range("A3"))
' Simple configuration
With pt
.PivotFields(wsData.Range("B1").Value).Orientation = xlRowField
.PivotFields(wsData.Range("E1").Value).Orientation = xlDataField
.PivotFields(wsData.Range("H1").Value).Orientation = xlDataField
.PivotFields(wsData.Range("I1").Value).Orientation = xlDataField
End With
' Simple formatting
wsPivot.Range("A1").Value = "Simple Material Summary"
wsPivot.Columns.AutoFit
MsgBox "Simple pivot table created successfully!", vbInformation
CleanUp:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Exit Sub
ErrorHandler:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical
GoTo CleanUp
End Sub
Sub CheckDataRange()
' Purpose: Check data range to help diagnose issues
Dim ws As Worksheet
Dim rng As Range
Dim lastRow As Long, lastCol As Long
Set ws = ThisWorkbook.Worksheets("KCB")
lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
MsgBox "Data Check:" & vbCrLf & _
"Last row: " & lastRow & vbCrLf & _
"Last column: " & lastCol & vbCrLf & _
"Header row data: " & ws.Range("A1").Value & "..." & ws.Cells(1, lastCol).Value, _
vbInformation, "Data Diagnostic"
' Show a sample of the data
If lastRow > 1 Then
Set rng = ws.Range("A1").Resize(2, lastCol)
rng.Select
End If
End Sub
Module21.bas - MKey()
Sub MKey()
' Declare variables
Dim wsBOM As Worksheet
Dim wsTarget As Worksheet
Dim dict As Object
Dim lastRowBOM As Long
Dim lastRowTarget As Long
Dim i As Long
Dim primaryKey As String
Dim model As String
Dim modelKey As String
Dim dataArray As Variant
Dim resultArray() As String
Dim modelArray() As String
Dim j As Long
Dim isDuplicate As Boolean
Dim foundKeys As Object
Dim originalColumnWidth As Double
' Save original column B width
On Error Resume Next
originalColumnWidth = Worksheets("0000").Columns("B").Width
On Error GoTo 0
' Turn off screen updating and calculation for speed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error GoTo ErrorHandler
' Set worksheets
On Error Resume Next
Set wsBOM = Worksheets("BOM_BUFFER")
Set wsTarget = Worksheets("0000")
On Error GoTo ErrorHandler
If wsBOM Is Nothing Then
MsgBox "Worksheet 'BOM' not found!", vbExclamation
GoTo CleanUp
End If
If wsTarget Is Nothing Then
MsgBox "Worksheet '0000' not found!", vbExclamation
GoTo CleanUp
End If
' Create dictionaries for faster lookup
Set dict = CreateObject("Scripting.Dictionary")
Set foundKeys = CreateObject("Scripting.Dictionary")
' Get data from BOM sheet (A=model, B=primary key) starting from row 3
lastRowBOM = wsBOM.Cells(wsBOM.Rows.Count, "A").End(xlUp).Row
If lastRowBOM < 3 Then
MsgBox "No data found in BOM sheet (data should start from row 3)!", vbExclamation
GoTo CleanUp
End If
dataArray = wsBOM.Range("A3:B" & lastRowBOM).Value
' Build dictionary from BOM data (group models by primary key)
For i = 1 To UBound(dataArray, 1)
model = Trim(CStr(dataArray(i, 1))) ' Column A - model data
primaryKey = Trim(CStr(dataArray(i, 2))) ' Column B - primary key
' Validate data
If primaryKey <> "" And model <> "" Then
' MODIFIED: For models starting with "781" - keep first 9 characters
If Left(model, 3) = "781" Then
If Len(model) >= 9 Then
modelKey = Left(model, 9) ' Keep first 9 characters for 781 starting models
Else
modelKey = model ' If less than 9 chars, keep original
End If
Else
' Extract first 7 characters for other models
If Len(model) >= 7 Then
modelKey = Left(model, 7)
Else
modelKey = model
End If
End If
' Process by primary key
If dict.exists(primaryKey) Then
' Split existing models and check for duplicates
modelArray = Split(dict(primaryKey), ",")
isDuplicate = False
' Check if modelKey already exists for this primary key
For j = 0 To UBound(modelArray)
If Trim(modelArray(j)) = modelKey Then
isDuplicate = True
Exit For
End If
Next j
' Add only if not duplicate
If Not isDuplicate Then
dict(primaryKey) = dict(primaryKey) & "," & modelKey
End If
Else
' First entry for this primary key
dict(primaryKey) = modelKey
End If
End If
Next i
' Get target range from 0000 sheet (column A = primary keys) starting from row 3
lastRowTarget = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row
If lastRowTarget < 3 Then
MsgBox "No primary keys found in 0000 sheet (data should start from row 3)!", vbExclamation
GoTo CleanUp
End If
' Prepare result array for column B starting from row 3
ReDim resultArray(1 To lastRowTarget - 2, 1 To 1)
' Match models to primary keys - using direct cell reference instead of range variable
For i = 3 To lastRowTarget
primaryKey = Trim(CStr(wsTarget.Cells(i, 1).Value))
If primaryKey <> "" Then
If dict.exists(primaryKey) Then
resultArray(i - 2, 1) = Replace(dict(primaryKey), ",", ", ")
foundKeys(primaryKey) = True
Else
resultArray(i - 2, 1) = "Not Found"
End If
Else
resultArray(i - 2, 1) = ""
End If
Next i
' Insert results into column B of 0000 sheet starting from row 3
wsTarget.Range("B3:B" & lastRowTarget).Value = resultArray
' Restore original column width instead of auto-fit
wsTarget.Columns("B").Width = originalColumnWidth
' Show