系列文章目录
文章目录
- 系列文章目录
- 前言
- 一、外观报表
- 1.产能统计
- 2.单板数
- 3.固定伤排查
- 4.件号良率
- 5.镜片批退率
- 6.镜筒批退率
- 总结
前言
一、外观报表
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 Function2.单板数
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 Sub3.固定伤排查
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 Sub4.件号良率
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 Sub5.镜片批退率
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 Sub6.镜筒批退率
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 Subexcel文件
总结
分享：
我生于农耕之家，相貌平平，落地无天地异象，身无血脉之力，又是肉体凡胎，一生无法修炼，终归寿命不过百载，蹉跎半生，至今无一道侣，长于山野之间，幸家中几亩寿田，得以苟活幸存，权杖上天垂青，方能蜷缩万丈红尘，学堂几年，憧憬一飞冲天，无奈名落孙山，止于硕研，上可上九天之高楼搬砖，下可下十景之清洁道管，他乡漂泊数年，奇遇良人如斯，与恶人如虎，常遭小人之计，踏韭菜之坑，尝遍人间疾苦，混迹江湖未见盖世功勋，虽命比纸薄，心恨天高，胡服人间，百折不挠，隐于尘烟，偶得逍遥，学富虽无无车，却喜舞文弄墨，处恶劣之环境，思繁华之人生，居于市井窥视庙堂，偶尔故作高深装模作样，人前不敢卸下伪装，人后不敢直视内心肮脏，欲望常有，眼界未增，只剩囫囵一生，既非混世魔王，也非盖世英雄，放生时慈悲为怀，杀生时手起刀快，既辜负了观音，也辜负了如来，苟且红尘偷生，虚度年华光阴，愧疚为人子，为敬人之孝心，此生为人，实属意外。
![[蓝桥杯]最大化股票交易的利润](http://pic.xiahunao.cn/[蓝桥杯]最大化股票交易的利润)
![[论文阅读]PPT: Backdoor Attacks on Pre-trained Models via Poisoned Prompt Tuning](http://pic.xiahunao.cn/[论文阅读]PPT: Backdoor Attacks on Pre-trained Models via Poisoned Prompt Tuning)
