commit 182f90b6234beceeb21dc04260cbdcb29f2bfb8d Author: 1803560007 <1803560007@qq.com> Date: Tue Apr 7 11:45:46 2026 +0800 Initial commit: VBA source from 全機型_日報表.xlsm (2026-04-07) diff --git a/README.md b/README.md new file mode 100644 index 0000000..6aefe31 --- /dev/null +++ b/README.md @@ -0,0 +1,53 @@ +# Marui_Work_VBA + +全機型_日報表.xlsm 的 VBA 原始碼存檔 + +## 來源文件 +- 原始檔案：`全機型_日報表.xlsm`（位於 Marui_Work 倉庫） +- 提取日期：2026-04-07 +- 檔案大小：1.6MB（含二進制 VBA 模組） + +## 模組架構 + +### 主流程 +| 巨集 | 說明 | +|------|------| +| `Module5.A()` | 呼叫 B() → Q()，全機型主流程 | +| `Module6.B()` | 讀取 FCST + BOM，展開料號至 Output 表 | +| `Module3.Q()` | 對 Output 創建透視表 WeeklySummaryPivot | + +### LG 專用版本 +| 巨集 | 說明 | +|------|------| +| `Module29.A_LG()` | LG 主流程 | +| `Module27.B_LG()` | 處理 LG 預測數據 | +| `Module28.Q_LG()` | 創建 WeeklySummaryPivot_LG | + +### 數據轉換 +| 巨集 | 說明 | +|------|------| +| `Module32.JQ_ConvertHorizontalWeeklyToMonthly()` | 橫向周數據 → 縱向月數據 | +| `Module24.LG_WEEK()` | LG 周數據透視表 | +| `Module31.QF()` | 短缺數據（qs表）轉橫向表格 | + +### 工具函數 +| 函數 | 說明 | +|------|------| +| `ra()` | 正則提取料號（6-25位大寫數字） | +| `NT()` | 列號轉字母 | +| `MKey()` | BOM 緩衝區匹配至 0000 表 | +| `MKey_LG()` | BOM 緩衝區匹配至 LG_Buffer 表 | +| `OptimizeVBA()` | 效能優化開關 | +| `WorksheetExists()` | 工作表存在性檢查 | + +## 工作表結構 +- `FCST` - 預測數據 +- `BOM` - 物料清單 +- `KCB` - MaterialSummary 數據源 +- `LG` - LG 專用預測 +- `BOM_BUFFER` - 緩衝區 BOM +- `0000` / `LG_Buffer` - 匹配目標 +- `qs` - 短缺數據 +- `Output` / `Output_LG` - 展開輸出 +- `Cutput` / `Cutput_LG` - 透視表輸出 +- `Unmatched` / `Unmatched_LG` - 未匹配料號 diff --git a/vba_modules.md b/vba_modules.md new file mode 100644 index 0000000..56212c6 --- /dev/null +++ b/vba_modules.md @@ -0,0 +1,1008 @@ +# VBA 模組原始碼 +# 來源：全機型_日報表.xlsm +# 提取工具：olevba 0.60.2 +# 提取時間：2026-04-07 + +--- + +## Module19.bas - NT() + +```vba +Function NT(Number As Integer) As String + NT = Split(Cells(1, Number).Address, "$")(1) +End Function +``` + +--- + +## Module7.bas - ra() + +```vba +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() + +```vba +Sub A() + Call B + Call Q +End Sub +``` + +--- + +## Module6.bas - B() + +```vba +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() + +```vba +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() + +```vba +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() + +```vba +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 \ No newline at end of file