系列文章目錄

---

前言

一、外觀報表

1.產能統計

Sub ProcessInspectionData()Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As WorksheetDim lastRow1 As Long, lastRow3 As LongDim dateCol As Range, empRange As RangeDim i As Long, j As Long, k As LongDim count As Long, holeCount As LongDim okHoles As String, ngHoles As StringDim inspector As String, checkDate As Date' 初始化工作表對象Set ws1 = ThisWorkbook.Sheets("鏡片抽檢履歷")Set ws2 = ThisWorkbook.Sheets("人員產能")Set ws3 = ThisWorkbook.Sheets("鏡筒抽檢履歷")' 清除原有數據ws2.Range("F3:AJ82").ClearContents' 獲取日期列范圍Set dateCol = ws2.Range("F2:AJ2")' 處理鏡片抽檢履歷(Sheet1)lastRow1 = ws1.Cells(ws1.Rows.count, "B").End(xlUp).RowFor i = 4 To lastRow1checkDate = ws1.Cells(i, "B").valueinspector = ws1.Cells(i, "O").valueokHoles = ws1.Cells(i, "J").valuengHoles = ws1.Cells(i, "K").value' 計算穴號總數holeCount = CountHoles(okHoles) + CountHoles(ngHoles)' 查找匹配的日期列For j = 1 To dateCol.Columns.countIf dateCol.Cells(1, j).value = checkDate Then' 情況1: J列和K列均為空If okHoles = "" And ngHoles = "" ThenSet empRange = ws2.Range("D3:D22")For k = 1 To empRange.Rows.countIf empRange.Cells(k, 1).value = inspector Thenws2.Cells(k + 2, j + 5).value = Nz(ws2.Cells(k + 2, j + 5).value) + 3Exit ForEnd IfNext k' 情況2: 有穴號但總數<3ElseIf holeCount > 0 And holeCount < 3 ThenSet empRange = ws2.Range("D23:D42")For k = 1 To empRange.Rows.countIf empRange.Cells(k, 1).value = inspector Thenws2.Cells(k + 22, j + 5).value = Nz(ws2.Cells(k + 22, j + 5).value) + 3Exit ForEnd IfNext k' 情況3: 有穴號且總數>=3ElseIf holeCount >= 3 ThenSet empRange = ws2.Range("D23:D42")For k = 1 To empRange.Rows.countIf empRange.Cells(k, 1).value = inspector Thenws2.Cells(k + 22, j + 5).value = Nz(ws2.Cells(k + 22, j + 5).value) + holeCountExit ForEnd IfNext kEnd IfExit ForEnd IfNext jNext i' 處理鏡筒抽檢履歷(Sheet3)lastRow3 = ws3.Cells(ws3.Rows.count, "B").End(xlUp).RowFor i = 4 To lastRow3checkDate = ws3.Cells(i, "B").valueinspector = ws3.Cells(i, "N").valueokHoles = ws3.Cells(i, "I").valuengHoles = ws3.Cells(i, "J").value' 計算穴號總數holeCount = CountHoles(okHoles) + CountHoles(ngHoles)' 查找匹配的日期列For j = 1 To dateCol.Columns.countIf dateCol.Cells(1, j).value = checkDate Then' 情況4: 有穴號但總數<3If holeCount > 0 And holeCount < 3 ThenSet empRange = ws2.Range("D43:D62")For k = 1 To empRange.Rows.countIf empRange.Cells(k, 1).value = inspector Thenws2.Cells(k + 42, j + 5).value = Nz(ws2.Cells(k + 42, j + 5).value) + 3Exit ForEnd IfNext k' 情況5: 有穴號且總數>=3ElseIf holeCount >= 3 ThenSet empRange = ws2.Range("D43:D62")For k = 1 To empRange.Rows.countIf empRange.Cells(k, 1).value = inspector Thenws2.Cells(k + 42, j + 5).value = Nz(ws2.Cells(k + 42, j + 5).value) + holeCountExit ForEnd IfNext kEnd IfExit ForEnd IfNext jNext i' 計算總和(D63:D82)For j = 1 To dateCol.Columns.countFor k = 1 To 20ws2.Cells(k + 62, j + 5).value = _Nz(ws2.Cells(k + 2, j + 5).value) + _Nz(ws2.Cells(k + 22, j + 5).value) + _Nz(ws2.Cells(k + 42, j + 5).value)If ws2.Cells(k + 62, j + 5).value = 0 Thenws2.Cells(k + 62, j + 5).value = ""End IfNext kNext jMsgBox "產能匯總完成!", vbInformation
End SubFunction CountHoles(holeStr As String) As LongIf holeStr = "" Then Exit FunctionCountHoles = UBound(Split(holeStr, "+")) + 1
End FunctionFunction Nz(value As Variant) As LongIf IsEmpty(value) Or value = "" ThenNz = 0ElseNz = CLng(value)End If
End Function

2.單板數

Sub MatchAndFillData()Dim ws1 As Worksheet, ws2 As WorksheetDim lastRow1 As Long, lastRow2 As LongDim i As Long, j As LongDim found As BooleanApplication.ScreenUpdating = False'設置工作表對象Set ws1 = Worksheets("單板數整理")Set ws2 = Worksheets("鏡片抽檢履歷")'獲取最后數據行lastRow1 = ws1.Cells(ws1.Rows.count, "A").End(xlUp).RowlastRow2 = ws2.Cells(ws2.Rows.count, "H").End(xlUp).Row'遍歷Sheet2數據For i = 4 To lastRow2found = False'在Sheet1中查找匹配項For j = 2 To lastRow1If ws2.Cells(i, "H").value = ws1.Cells(j, "A").value And _ws2.Cells(i, "I").value = ws1.Cells(j, "B").value Thenws2.Cells(i, "L").value = ws1.Cells(j, "C").valuefound = TrueExit ForEnd IfNext j'未找到匹配項的處理If Not found Thenws2.Cells(i, "L").value = "未查到對應單板數，請錄入"End IfNext iMsgBox "數據匹配完成！", vbInformation
End Sub

3.固定傷排查

Sub ExtractAndMarkLensData()Dim ws1 As Worksheet, ws2 As WorksheetDim dict As Object, okDict As Object, ngDict As ObjectDim lastRow As Long, i As Long, j As LongDim startDate As Date, endDate As DateDim outputRow As Long, colIndex As IntegerDim key As String, numbers As VariantDim item As Variant, sortedItems(), tempApplication.ScreenUpdating = FalseSet ws1 = ThisWorkbook.Sheets("鏡片抽檢履歷")Set ws2 = ThisWorkbook.Sheets("固定傷排查")Set dict = CreateObject("Scripting.Dictionary")Set okDict = CreateObject("Scripting.Dictionary")Set ngDict = CreateObject("Scripting.Dictionary")' 獲取日期范圍On Error Resume NextstartDate = CDate(ws2.Range("A3").value)endDate = CDate(ws2.Range("B3").value)On Error GoTo 0If startDate = 0 Or endDate = 0 ThenMsgBox "日期格式錯誤，請檢查A3/B3單元格", vbCriticalExit SubEnd IflastRow = ws1.Cells(ws1.Rows.count, "B").End(xlUp).Rowws2.Range("A5:AM" & ws2.Rows.count).ClearContentsws2.Range("A5:AM" & ws2.Rows.count).Interior.ColorIndex = xlNone' 數據收集階段For i = 4 To lastRowDim currentDate As DatecurrentDate = CDate(ws1.Cells(i, "B").value)If currentDate >= startDate And currentDate <= endDate Thenkey = ws1.Cells(i, "G").value & "|" & ws1.Cells(i, "H").value & "|" & ws1.Cells(i, "I").value' 存儲基礎數據If Not dict.Exists(key) Thendict.Add key, Array(ws1.Cells(i, "G").value, ws1.Cells(i, "H").value, ws1.Cells(i, "I").value)End If' 處理OK/NG穴號（優先處理NG）ProcessHoleNumbers ws1.Cells(i, "K").value, ngDict, keyProcessHoleNumbers ws1.Cells(i, "J").value, okDict, keyEnd IfNext i' 將字典項轉換為數組并排序（修正下標越界問題）If dict.count > 0 ThenReDim sortedItems(1 To dict.count)i = 1For Each item In dict.ItemssortedItems(i) = itemi = i + 1Next' 冒泡排序按H列和I列雙重排序' === 三重排序開始 ===For i = 1 To UBound(sortedItems) - 1For j = i + 1 To UBound(sortedItems)' 第一優先級：H列（機種）If sortedItems(i)(1) > sortedItems(j)(1) Thentemp = sortedItems(i)sortedItems(i) = sortedItems(j)sortedItems(j) = temp' H列相同時比較I列ElseIf sortedItems(i)(1) = sortedItems(j)(1) ThenIf sortedItems(i)(2) > sortedItems(j)(2) Thentemp = sortedItems(i)sortedItems(i) = sortedItems(j)sortedItems(j) = temp' H列和I列都相同時比較G列ElseIf sortedItems(i)(2) = sortedItems(j)(2) ThenIf sortedItems(i)(0) > sortedItems(j)(0) Thentemp = sortedItems(i)sortedItems(i) = sortedItems(j)sortedItems(j) = tempEnd IfEnd IfEnd IfNext jNext i' === 三重排序結束 ===End If' 數據輸出階段outputRow = 5If dict.count > 0 ThenFor i = 1 To UBound(sortedItems)key = sortedItems(i)(0) & "|" & sortedItems(i)(1) & "|" & sortedItems(i)(2)ws2.Cells(outputRow, "A").Resize(1, 3).value = sortedItems(i)' 標記NG穴號（紅色，優先處理）If ngDict.Exists(key) Thennumbers = Split(ngDict(key), "+")For Each num In numbersIf IsNumeric(num) ThencolIndex = CInt(num) + 3If colIndex >= 4 And colIndex <= 39 ThenWith ws2.Cells(outputRow, colIndex).value = "NG".Interior.Color = RGB(255, 0, 0)End WithEnd IfEnd IfNextEnd If' 標記OK穴號（綠色，排除已標記NG的）If okDict.Exists(key) Thennumbers = Split(okDict(key), "+")For Each num In numbersIf IsNumeric(num) ThencolIndex = CInt(num) + 3If colIndex >= 4 And colIndex <= 39 ThenIf ws2.Cells(outputRow, colIndex).value <> "NG" ThenWith ws2.Cells(outputRow, colIndex).value = "OK".Interior.Color = RGB(0, 255, 0)End WithEnd IfEnd IfEnd IfNextEnd IfoutputRow = outputRow + 1NextEnd IfApplication.ScreenUpdating = TrueMsgBox "處理完成！共提取 " & dict.count & " 條記錄", vbInformation
End SubPrivate Sub ProcessHoleNumbers(holeStr As String, ByRef dict As Object, key As String)If holeStr <> "" ThenDim numbers As Variant, num As Variantnumbers = Split(holeStr, "+")For Each num In numbersIf IsNumeric(num) ThenIf Not dict.Exists(key) Thendict.Add key, numElseIf InStr(dict(key), num) = 0 Thendict(key) = dict(key) & "+" & numEnd IfEnd IfNextEnd If
End Sub

4.件號良率

Sub CalculateYield()Dim wsInspect As Worksheet, wsYield As WorksheetDim lastRow As Long, i As Long, j As Long, k As LongDim dateCol As Range, modelCol As RangeDim inspectDate As Date, yieldDate As DateDim modelName As String, countTotal As Integer, countReject As IntegerDim dict As ObjectApplication.ScreenUpdating = FalseSet wsInspect = Worksheets("鏡片抽檢履歷")Set wsYield = Worksheets("件號良率")Set dict = CreateObject("Scripting.Dictionary")' 清空目標區域wsYield.Range("A3:A80").ClearContentswsYield.Range("C3:AG80").ClearContents' ===== 提取不重復機種并排序 =====lastRow = wsInspect.Cells(wsInspect.Rows.count, "H").End(xlUp).RowFor i = 4 To lastRowmodelName = Trim(wsInspect.Cells(i, 8).value)If modelName <> "" Then dict(modelName) = 1Next i' 排序并寫入機種列表Dim arrModels(), m As LongarrModels = dict.keysCall QuickSort(arrModels, LBound(arrModels), UBound(arrModels))For m = 0 To UBound(arrModels)wsYield.Cells(m + 3, 1).value = arrModels(m)Next m' ===== 計算良率 =====Set dateCol = wsYield.Range("C2:AG2")Set modelCol = wsYield.Range("A3:A80")For i = 1 To modelCol.Rows.countmodelName = Trim(modelCol.Cells(i, 1).value)If modelName = "" Then Exit ForFor j = 1 To dateCol.Columns.countyieldDate = dateCol.Cells(1, j).valuecountTotal = 0countReject = 0' 統計數據lastRow = wsInspect.Cells(wsInspect.Rows.count, "B").End(xlUp).RowFor k = 4 To lastRowIf IsDate(wsInspect.Cells(k, 2).value) TheninspectDate = CDate(wsInspect.Cells(k, 2).value)If inspectDate = yieldDate ThenIf Trim(wsInspect.Cells(k, 8).value) = modelName ThencountTotal = countTotal + 1If Trim(wsInspect.Cells(k, 16).value) = "退" ThencountReject = countReject + 1End IfEnd IfEnd IfEnd IfNext k' 計算并寫入良率If countTotal > 0 ThenwsYield.Cells(i + 2, j + 2).value = (1 - countReject / countTotal)wsYield.Cells(i + 2, j + 2).NumberFormat = "0.00%"End IfNext jNext iApplication.ScreenUpdating = TrueMsgBox "良率計算完成！", vbInformation
End Sub' 快速排序算法
Sub QuickSort(arr, first As Long, last As Long)Dim pivot As String, temp As StringDim low As Long, high As Longlow = firsthigh = lastpivot = arr((first + last) \ 2)Do While (low <= high)Do While (arr(low) < pivot And low < last)low = low + 1LoopDo While (pivot < arr(high) And high > first)high = high - 1LoopIf (low <= high) Thentemp = arr(low)arr(low) = arr(high)arr(high) = templow = low + 1high = high - 1End IfLoopIf (first < high) Then QuickSort arr, first, highIf (low < last) Then QuickSort arr, low, last
End Sub

5.鏡片批退率

Sub CalculateYieldRate()Dim wsData As Worksheet, wsReport As WorksheetDim startDate As Date, endDate As DateDim lastRow As Long, dict As ObjectDim arrData(), arrResult(), outputRow As LongDim i As Long, key As Variant, isSingleDate As Boolean' 初始化設置On Error GoTo ErrorHandlerApplication.ScreenUpdating = FalseSet wsData = Worksheets("鏡片抽檢履歷")Set wsReport = Worksheets("良率匯總")Set dict = CreateObject("Scripting.Dictionary")' 清除舊數據wsReport.Range("AC4:AF" & wsReport.Rows.count).ClearContents' 日期驗證處理If IsEmpty(wsReport.Range("AA2")) Or IsEmpty(wsReport.Range("AA4")) ThenMsgBox "請在AA2和AA4單元格輸入有效日期", vbCriticalExit SubEnd IfOn Error Resume NextstartDate = CDate(wsReport.Range("AA2").value)endDate = CDate(wsReport.Range("AA4").value)If Err.Number <> 0 ThenMsgBox "日期格式不正確，請檢查AA2和AA4單元格", vbCriticalExit SubEnd IfOn Error GoTo ErrorHandler' 判斷是單日期還是日期范圍isSingleDate = (DateDiff("d", startDate, endDate) = 0)' 數據加載lastRow = wsData.Cells(wsData.Rows.count, "B").End(xlUp).RowIf lastRow < 4 ThenMsgBox "抽檢履歷表無有效數據", vbExclamationExit SubEnd IfarrData = wsData.Range("B4:R" & lastRow).value' 核心統計邏輯For i = LBound(arrData) To UBound(arrData)If IsDate(arrData(i, 1)) ThenDim currentDate As DatecurrentDate = CDate(arrData(i, 1))' 檢查日期是否符合條件If (isSingleDate And DateValue(currentDate) = DateValue(startDate)) Or _(Not isSingleDate And currentDate >= startDate And currentDate <= endDate) ThenDim model As Stringmodel = Trim(CStr(arrData(i, 7)))' 跳過空機種If model = "" Then GoTo NextItem' 初始化字典項If Not dict.Exists(model) Thendict.Add model, Array(0, 0) ' (總批次, 退批次)End If' 統計總數和退料數（不使用total = dict(key)(0)方式）dict(model)(0) = dict(model)(0) + 1If Trim(arrData(i, 15)) = "退" Thendict(model)(1) = dict(model)(1) + 1End IfEnd IfEnd If
NextItem:Next i' 結果輸出If dict.count > 0 ThenReDim arrResult(1 To dict.count, 1 To 4)outputRow = 1' 使用字典鍵進行計數統計For Each key In dict.keysDim total As Long, reject As Longtotal = 0reject = 0' 重新計數（不使用dict(key)(0)方式）For i = LBound(arrData) To UBound(arrData)If IsDate(arrData(i, 1)) ThencurrentDate = CDate(arrData(i, 1))If (isSingleDate And DateValue(currentDate) = DateValue(startDate)) Or _(Not isSingleDate And currentDate >= startDate And currentDate <= endDate) ThenIf Trim(CStr(arrData(i, 7))) = key Thentotal = total + 1If Trim(arrData(i, 15)) = "退" Thenreject = reject + 1End IfEnd IfEnd IfEnd IfNext iarrResult(outputRow, 1) = keyarrResult(outputRow, 2) = totalarrResult(outputRow, 3) = rejectIf total > 0 ThenarrResult(outputRow, 4) = reject / totalElsearrResult(outputRow, 4) = 0End IfoutputRow = outputRow + 1Next keyWith wsReport.Range("AC4").Resize(dict.count, 4) = arrResult.Range("AF4:AF" & 3 + dict.count).NumberFormat = "0.00%"' 按批退率升序排序If dict.count > 1 Then.Range("AC4:AF" & 3 + dict.count).Sort _Key1:=.Range("AF4"), Order1:=xlDescending, _Header:=xlNoEnd IfEnd WithEnd IfApplication.ScreenUpdating = TrueMsgBox "處理完成！共統計 " & dict.count & " 個機種", vbInformationExit SubErrorHandler:Application.ScreenUpdating = TrueMsgBox "錯誤 " & Err.Number & ": " & Err.Description, vbCritical
End Sub

6.鏡筒批退率

Sub CalculateYieldRate()Dim wsData As Worksheet, wsReport As WorksheetDim startDate As Date, endDate As DateDim lastRow As Long, dict As ObjectDim arrData(), arrResult(), outputRow As LongDim i As Long, key As Variant, isSingleDate As Boolean' 初始化設置On Error GoTo ErrorHandlerApplication.ScreenUpdating = FalseSet wsData = Worksheets("鏡筒抽檢履歷")Set wsReport = Worksheets("良率匯總")Set dict = CreateObject("Scripting.Dictionary")' 清除舊數據wsReport.Range("AK4:AN" & wsReport.Rows.count).ClearContents' 日期驗證處理If IsEmpty(wsReport.Range("AI2")) Or IsEmpty(wsReport.Range("AI4")) ThenMsgBox "請在AI2和AI4單元格輸入有效日期", vbCriticalExit SubEnd IfOn Error Resume NextstartDate = CDate(wsReport.Range("AI2").value)endDate = CDate(wsReport.Range("AI4").value)If Err.Number <> 0 ThenMsgBox "日期格式不正確，請檢查AI2和AI4單元格", vbCriticalExit SubEnd IfOn Error GoTo ErrorHandler' 判斷是單日期還是日期范圍isSingleDate = (DateDiff("d", startDate, endDate) = 0)' 數據加載lastRow = wsData.Cells(wsData.Rows.count, "B").End(xlUp).RowIf lastRow < 4 ThenMsgBox "抽檢履歷表無有效數據", vbExclamationExit SubEnd IfarrData = wsData.Range("B4:O" & lastRow).value' 核心統計邏輯For i = LBound(arrData) To UBound(arrData)If IsDate(arrData(i, 1)) ThenDim currentDate As DatecurrentDate = CDate(arrData(i, 1))' 檢查日期是否符合條件If (isSingleDate And DateValue(currentDate) = DateValue(startDate)) Or _(Not isSingleDate And currentDate >= startDate And currentDate <= endDate) ThenDim model As Stringmodel = Trim(CStr(arrData(i, 6)))' 跳過空機種If model = "" Then GoTo NextItem' 初始化字典項If Not dict.Exists(model) Thendict.Add model, Array(0, 0) ' (總批次, 退批次)End If' 統計總數和退料數（不使用total = dict(key)(0)方式）dict(model)(0) = dict(model)(0) + 1If Trim(arrData(i, 14)) = "退" Thendict(model)(1) = dict(model)(1) + 1End IfEnd IfEnd If
NextItem:Next i' 結果輸出If dict.count > 0 ThenReDim arrResult(1 To dict.count, 1 To 4)outputRow = 1' 使用字典鍵進行計數統計For Each key In dict.keysDim total As Long, reject As Longtotal = 0reject = 0' 重新計數（不使用dict(key)(0)方式）For i = LBound(arrData) To UBound(arrData)If IsDate(arrData(i, 1)) ThencurrentDate = CDate(arrData(i, 1))If (isSingleDate And DateValue(currentDate) = DateValue(startDate)) Or _(Not isSingleDate And currentDate >= startDate And currentDate <= endDate) ThenIf Trim(CStr(arrData(i, 6))) = key Thentotal = total + 1If Trim(arrData(i, 14)) = "退" Thenreject = reject + 1End IfEnd IfEnd IfEnd IfNext iarrResult(outputRow, 1) = keyarrResult(outputRow, 2) = totalarrResult(outputRow, 3) = rejectIf total > 0 ThenarrResult(outputRow, 4) = reject / totalElsearrResult(outputRow, 4) = 0End IfoutputRow = outputRow + 1Next keyWith wsReport.Range("AK4").Resize(dict.count, 4) = arrResult.Range("AN4:AN" & 3 + dict.count).NumberFormat = "0.00%"' 按批退率升序排序If dict.count > 1 Then.Range("AK4:AN" & 3 + dict.count).Sort _Key1:=.Range("AN4"), Order1:=xlDescending, _Header:=xlNoEnd IfEnd WithEnd IfApplication.ScreenUpdating = TrueMsgBox "處理完成！共統計 " & dict.count & " 個機種", vbInformationExit SubErrorHandler:Application.ScreenUpdating = TrueMsgBox "錯誤 " & Err.Number & ": " & Err.Description, vbCritical
End Sub

excel文件

---

總結

分享：
我生于農耕之家，相貌平平，落地無天地異象，身無血脈之力，又是肉體凡胎，一生無法修煉，終歸壽命不過百載，蹉跎半生，至今無一道侶，長于山野之間，幸家中幾畝壽田，得以茍活幸存，權杖上天垂青，方能蜷縮萬丈紅塵，學堂幾年，憧憬一飛沖天，無奈名落孫山，止于碩研，上可上九天之高樓搬磚，下可下十景之清潔道管，他鄉漂泊數年，奇遇良人如斯，與惡人如虎，常遭小人之計，踏韭菜之坑，嘗遍人間疾苦，混跡江湖未見蓋世功勛，雖命比紙薄，心恨天高，胡服人間，百折不撓，隱于塵煙，偶得逍遙，學富雖無無車，卻喜舞文弄墨，處惡劣之環境，思繁華之人生，居于市井窺視廟堂，偶爾故作高深裝模作樣，人前不敢卸下偽裝，人后不敢直視內心骯臟，欲望常有，眼界未增，只剩囫圇一生，既非混世魔王，也非蓋世英雄，放生時慈悲為懷，殺生時手起刀快，既辜負了觀音，也辜負了如來，茍且紅塵偷生，虛度年華光陰，愧疚為人子，為敬人之孝心，此生為人，實屬意外。