系列文章目录

前言

一、外观报表

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 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

3.镜片不良TOP

Sub CalculateLensDefects()Dim srcSheet As Worksheet, dstSheet As WorksheetDim lastRow As Long, i As Long, col As LongDim startDate As Date, endDate As DateDim machineType As StringDim defectTitles(1 To 20) As StringDim defectSums(1 To 20) As Double' 设置工作表对象Set srcSheet = Worksheets("镜片抽检履历")Set dstSheet = Worksheets("良率汇总")dstSheet.Range("Z19:AA38").ClearContents' 复制缺陷类型标题到Z列（S3:AL3 → Z19:Z38）For col = 19 To 38defectTitles(col - 18) = srcSheet.Cells(3, col).valuedstSheet.Cells(18 + (col - 18), "Z").value = defectTitles(col - 18)Next col' 获取筛选条件startDate = dstSheet.Range("AA2").valueendDate = dstSheet.Range("AA4").valuemachineType = Trim(dstSheet.Range("AA11").value)' 初始化统计数组For i = 1 To 20defectSums(i) = 0Next i' 计算有效数据行数lastRow = srcSheet.Cells(srcSheet.Rows.count, "B").End(xlUp).Row' 核心统计逻辑For i = 4 To lastRow' 日期范围筛选（B列）If srcSheet.Cells(i, "B").value >= startDate And _srcSheet.Cells(i, "B").value <= endDate Then' 机种条件判断（H列）If machineType = "全部机种" Or srcSheet.Cells(i, "H").value = machineType Then' 累加各缺陷类型数量（S:AL列）For col = 19 To 38If IsNumeric(srcSheet.Cells(i, col).value) ThendefectSums(col - 18) = defectSums(col - 18) + srcSheet.Cells(i, col).valueEnd IfNext colEnd IfEnd IfNext i' 输出统计结果到AA列（S列和→AA19，T列和→AA20...）For i = 1 To 20dstSheet.Cells(18 + i, "AA").value = defectSums(i)Next i' 按缺陷数量升序排序（Z19:AA38区域）With dstSheet.Range("Z19:AA38").Sort Key1:=.Columns(2), Order1:=xlDescending, Header:=xlNo  'xlAscendingEnd WithMsgBox "镜片质量分析完成：" & vbCrLf & _"统计时段：" & startDate & " 至 " & endDate & vbCrLf & _IIf(machineType <> "", "指定机种：" & machineType, "全部机种"), _vbInformation, "操作完成"
End Sub

4.镜片公式计算

Option Explicit
Sub ProcessLensData()Dim wsLens As Worksheet, wsData As WorksheetDim lastRow As Long, i As LongDim missingList As String, errorLog As StringDim dict As Object, startDate As Date, endDate As DateSet dict = CreateObject("Scripting.Dictionary")Set wsLens = Sheets("镜片抽检履历")Set wsData = Sheets("单板数整理")' 获取日期范围With wsLensstartDate = .Range("M2").valueendDate = .Range("Q2").valueEnd With' 构建机种件号字典With wsDataFor i = 2 To .Cells(.Rows.count, 1).End(xlUp).Rowdict(.Cells(i, 1).value & "|" & .Cells(i, 2).value) = .Cells(i, 3).valueNextEnd With' 主处理流程With wsLenslastRow = .Cells(.Rows.count, 2).End(xlUp).RowFor i = 4 To lastRowOn Error Resume NextIf IsDate(.Cells(i, 2).value) ThenIf .Cells(i, 2).value >= startDate And .Cells(i, 2).value <= endDate ThenProcessLensRow .Rows(i), dict, missingList, errorLogEnd IfEnd IfNextEnd With' 输出结果If Len(missingList) > 0 Then MsgBox "未匹配记录：" & vbCrLf & missingListIf Len(errorLog) > 0 Then MsgBox "处理错误：" & errorLogMsgBox "镜片抽检数据处理完成！", vbInformation
End SubPrivate Sub ProcessLensRow(rng As Range, dict As Object, ByRef missList As String, ByRef errLog As String)Dim key As String, numCount As IntegerOn Error GoTo ErrorHandler' 任务1：单板数匹配key = rng.Cells(1, 8).value & "|" & rng.Cells(1, 9).valueIf dict.exists(key) Thenrng.Cells(1, 12).value = dict(key)Elserng.Cells(1, 12).value = "请录入该机种单板数"missList = missList & key & vbCrLfEnd If' 任务2：抽检数计算numCount = CountNumbers(rng.Cells(1, 10).value) + CountNumbers(rng.Cells(1, 11).value)rng.Cells(1, 13).value = rng.Cells(1, 12).value * IIf(numCount >= 3, numCount, 3)' 任务3-5处理With rng.Cells(1, 17).value = Application.Sum(.Range("S1:AL1"))If .Cells(1, 13).value <> 0 Then.Cells(1, 18).value = .Cells(1, 17).value / .Cells(1, 13).value.Cells(1, 18).NumberFormat = "0.0%"End If.Cells(1, 16).value = IIf(.Cells(1, 18).value > 0.02 Or _AnyPositive(.Range("Y1,AB1,AJ1,AL1,AH1,AI1,AK1")), "退", "入")End WithExit SubErrorHandler:errLog = errLog & "行" & rng.Row & "列" & Split(Err.Source, "$")(1) & "; "
End Sub

5.镜片良率计算

Option ExplicitSub CalculateYieldAndAverage()Dim wsSource As Worksheet, wsTarget As WorksheetDim lastRow As Long, i As Long, j As Long, k As LongDim dictMachine As Object, arrMachines(), arrDates()Dim arrResults(), totalCount As Long, rejectCount As LongDim targetDate As Date, currentMachine As StringDim sumValues As Double, countValues As Long' 设置工作表对象Set wsSource = Worksheets("镜片抽检履历")Set wsTarget = Worksheets("镜片机种良率")Set dictMachine = CreateObject("Scripting.Dictionary")' 清除目标区域wsTarget.Range("A3:AG1000").ClearContents' 获取机种不重复值（H列）lastRow = wsSource.Cells(wsSource.Rows.count, "H").End(xlUp).RowFor i = 4 To lastRowcurrentMachine = Trim(wsSource.Cells(i, "H").value)If currentMachine <> "" And Not dictMachine.exists(currentMachine) ThendictMachine.Add currentMachine, 1End IfNext i' 排序并输出机种到A列arrMachines = dictMachine.keysCall BubbleSort(arrMachines)wsTarget.Range("A3").Resize(UBound(arrMachines) + 1).value = Application.Transpose(arrMachines)' 获取日期范围（C2:AG2）arrDates = wsTarget.Range("C2:AG2").value' 初始化结果数组ReDim arrResults(1 To UBound(arrMachines) + 1, 1 To UBound(arrDates, 2))' 计算良率矩阵For i = 1 To UBound(arrMachines) + 1For j = 1 To UBound(arrDates, 2)targetDate = arrDates(1, j)totalCount = 0rejectCount = 0' 统计符合条件的数据For k = 4 To lastRowIf wsSource.Cells(k, "H").value = arrMachines(i - 1) And _wsSource.Cells(k, "B").value = targetDate ThentotalCount = totalCount + 1If wsSource.Cells(k, "P").value = "退" ThenrejectCount = rejectCount + 1End IfEnd IfNext k' 计算良率百分比If totalCount > 0 ThenarrResults(i, j) = Round((totalCount - rejectCount) / totalCount, 4)End IfNext jNext i' 输出结果并设置格式With wsTarget.Range("C3").Resize(UBound(arrResults, 1), UBound(arrResults, 2)).value = arrResults.NumberFormat = "0.00%"End With' 计算行平均值For i = 1 To UBound(arrMachines) + 1sumValues = 0countValues = 0For j = 1 To UBound(arrDates, 2)If Not IsEmpty(arrResults(i, j)) ThensumValues = sumValues + arrResults(i, j)countValues = countValues + 1End IfNext jIf countValues > 0 ThenwsTarget.Cells(2 + i, "B").value = Round(sumValues / countValues, 4)End IfNext i' 设置平均值列格式wsTarget.Range("B3:B1000").NumberFormat = "0.00%"MsgBox "计算完成：" & vbCrLf & _"处理机种数量：" & UBound(arrMachines) + 1 & vbCrLf & _"处理日期数量：" & UBound(arrDates, 2), vbInformation
End Sub' 冒泡排序算法
Sub BubbleSort(arr)Dim i As Long, j As LongDim temp As VariantFor i = LBound(arr) To UBound(arr) - 1For j = i + 1 To UBound(arr)If arr(i) > arr(j) Thentemp = arr(i)arr(i) = arr(j)arr(j) = tempEnd IfNext jNext i
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("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

7.镜筒不良TOP

Sub CalculateLensDefects()Dim srcSheet As Worksheet, dstSheet As WorksheetDim lastRow As Long, i As Long, col As LongDim startDate As Date, endDate As DateDim machineType As StringDim defectTitles(1 To 12) As StringDim defectSums(1 To 12) As Double' 设置工作表对象Set srcSheet = Worksheets("镜筒抽检履历")Set dstSheet = Worksheets("良率汇总")dstSheet.Range("AH19:AI30").ClearContents' 复制缺陷类型标题到AH列（R3:AC3 → AH19:AH30）For col = 18 To 29defectTitles(col - 17) = srcSheet.Cells(3, col).valuedstSheet.Cells(18 + (col - 17), "AH").value = defectTitles(col - 17)Next col' 获取筛选条件startDate = dstSheet.Range("AI2").valueendDate = dstSheet.Range("AI4").valuemachineType = Trim(dstSheet.Range("AI11").value)' 初始化统计数组For i = 1 To 12defectSums(i) = 0Next i' 计算有效数据行数lastRow = srcSheet.Cells(srcSheet.Rows.count, "B").End(xlUp).Row' 核心统计逻辑For i = 4 To lastRow' 日期范围筛选（B列）If srcSheet.Cells(i, "B").value >= startDate And _srcSheet.Cells(i, "B").value <= endDate Then' 机种条件判断（G列）If machineType = "全部机种" Or srcSheet.Cells(i, "G").value = machineType Then' 累加各缺陷类型数量（R:AC列）For col = 18 To 29If IsNumeric(srcSheet.Cells(i, col).value) ThendefectSums(col - 17) = defectSums(col - 17) + srcSheet.Cells(i, col).valueEnd IfNext colEnd IfEnd IfNext i' 输出统计结果到AI列（R列和→AI19，S列和→AI20...）For i = 1 To 12dstSheet.Cells(18 + i, "AI").value = defectSums(i)Next i' 按缺陷数量升序排序（AH19:AI30区域）With dstSheet.Range("AH19:AI30").Sort Key1:=.Columns(2), Order1:=xlDescending, Header:=xlNoEnd WithMsgBox "镜筒质量分析完成：" & vbCrLf & _"统计时段：" & startDate & " 至 " & endDate & vbCrLf & _IIf(machineType <> "", "指定机种：" & machineType, "全部机种"), _vbInformation, "操作完成"
End Sub

8.镜筒公式计算

Option Explicit
Sub ProcessBarrelData()Dim wsBarrel As Worksheet, wsData As WorksheetDim lastRow As Long, i As LongDim missingList As String, errorLog As StringDim dict As Object, startDate As Date, endDate As DateSet dict = CreateObject("Scripting.Dictionary")Set wsBarrel = Sheets("镜筒抽检履历")Set wsData = Sheets("单板数整理")' 获取日期范围With wsBarrelstartDate = .Range("L2").valueendDate = .Range("P2").valueEnd With' 构建机种件号字典With wsDataFor i = 2 To .Cells(.Rows.count, 1).End(xlUp).Rowdict(.Cells(i, 1).value & "|" & .Cells(i, 2).value) = .Cells(i, 3).valueNextEnd With' 主处理流程With wsBarrellastRow = .Cells(.Rows.count, 2).End(xlUp).RowFor i = 4 To lastRowOn Error Resume NextIf IsDate(.Cells(i, 2).value) ThenIf .Cells(i, 2).value >= startDate And .Cells(i, 2).value <= endDate ThenProcessBarrelRow .Rows(i), dict, missingList, errorLogEnd IfEnd IfNextEnd With' 输出结果If Len(missingList) > 0 Then MsgBox "未匹配记录：" & vbCrLf & missingListIf Len(errorLog) > 0 Then MsgBox "处理错误：" & errorLogMsgBox "镜片抽检数据处理完成！", vbInformation
End SubPrivate Sub ProcessBarrelRow(rng As Range, dict As Object, ByRef missList As String, ByRef errLog As String)Dim key As String, numCount As IntegerOn Error GoTo ErrorHandler' 任务6：单板数匹配key = rng.Cells(1, 7).value & "|" & rng.Cells(1, 8).valueIf dict.exists(key) Thenrng.Cells(1, 11).value = dict(key)Elserng.Cells(1, 11).value = "请录入该机种单板数"missList = missList & key & vbCrLfEnd If' 任务7：抽检数计算numCount = CountNumbers(rng.Cells(1, 9).value) + CountNumbers(rng.Cells(1, 10).value)rng.Cells(1, 12).value = rng.Cells(1, 11).value * IIf(numCount >= 3, numCount, 3)' 任务8-10处理With rng.Cells(1, 16).value = Application.Sum(.Range("R1:AC1"))If .Cells(1, 12).value <> 0 Then.Cells(1, 17).value = .Cells(1, 16).value / .Cells(1, 12).value.Cells(1, 17).NumberFormat = "0.0%"End If.Cells(1, 15).value = IIf(.Cells(1, 17).value > 0.02 Or _.Cells(1, 28).value > 0, "退", "入")End WithExit SubErrorHandler:errLog = errLog & "行" & rng.Row & "列" & Split(Err.Source, "$")(1) & "; "
End Sub

9.镜筒良率计算

Sub CalculateYieldAndAverage()Dim wsSource As Worksheet, wsTarget As WorksheetDim lastRow As Long, i As Long, j As Long, k As LongDim dictMachine As Object, arrMachines(), arrDates()Dim arrResults(), totalCount As Long, rejectCount As LongDim targetDate As Date, currentMachine As StringDim sumValues As Double, countValues As Long' 设置工作表对象Set wsSource = Worksheets("镜筒抽检履历")Set wsTarget = Worksheets("镜筒机种良率")Set dictMachine = CreateObject("Scripting.Dictionary")' 清除目标区域wsTarget.Range("A3:AG1000").ClearContents' 获取机种不重复值（G列）lastRow = wsSource.Cells(wsSource.Rows.count, "G").End(xlUp).RowFor i = 4 To lastRowcurrentMachine = Trim(wsSource.Cells(i, "G").value)If currentMachine <> "" And Not dictMachine.exists(currentMachine) ThendictMachine.Add currentMachine, 1End IfNext i' 排序并输出机种到A列arrMachines = dictMachine.keysCall BubbleSort(arrMachines)wsTarget.Range("A3").Resize(UBound(arrMachines) + 1).value = Application.Transpose(arrMachines)' 获取日期范围（C2:AG2）arrDates = wsTarget.Range("C2:AG2").value' 初始化结果数组ReDim arrResults(1 To UBound(arrMachines) + 1, 1 To UBound(arrDates, 2))' 计算良率矩阵For i = 1 To UBound(arrMachines) + 1For j = 1 To UBound(arrDates, 2)targetDate = arrDates(1, j)totalCount = 0rejectCount = 0' 统计符合条件的数据For k = 4 To lastRowIf wsSource.Cells(k, "G").value = arrMachines(i - 1) And _wsSource.Cells(k, "B").value = targetDate ThentotalCount = totalCount + 1If wsSource.Cells(k, "O").value = "退" ThenrejectCount = rejectCount + 1End IfEnd IfNext k' 计算良率百分比If totalCount > 0 ThenarrResults(i, j) = Round((totalCount - rejectCount) / totalCount, 4)End IfNext jNext i' 输出结果并设置格式With wsTarget.Range("C3").Resize(UBound(arrResults, 1), UBound(arrResults, 2)).value = arrResults.NumberFormat = "0.00%"End With' 计算行平均值For i = 1 To UBound(arrMachines) + 1sumValues = 0countValues = 0For j = 1 To UBound(arrDates, 2)If Not IsEmpty(arrResults(i, j)) ThensumValues = sumValues + arrResults(i, j)countValues = countValues + 1End IfNext jIf countValues > 0 ThenwsTarget.Cells(2 + i, "B").value = Round(sumValues / countValues, 4)End IfNext i' 设置平均值列格式wsTarget.Range("B3:B1000").NumberFormat = "0.00%"MsgBox "计算完成：" & vbCrLf & _"处理机种数量：" & UBound(arrMachines) + 1 & vbCrLf & _"处理日期数量：" & UBound(arrDates, 2), vbInformation
End Sub' 冒泡排序算法
Sub BubbleSort(arr)Dim i As Long, j As LongDim temp As VariantFor i = LBound(arr) To UBound(arr) - 1For j = i + 1 To UBound(arr)If arr(i) > arr(j) Thentemp = arr(i)arr(i) = arr(j)arr(j) = tempEnd IfNext jNext i
End Sub

10.镜筒批退率

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

二、反射率报表

1.机台通过率

Option ExplicitSub AnalyzeMachinePassRate()Dim ws1 As Worksheet, ws2 As WorksheetDim lastRow1 As Long, lastRow2 As LongDim startDate As Date, endDate As DateDim dict As Object, key As StringDim i As Long, j As Long, k As LongDim dateCol As LongDim a As Long, b As Long, c As Long, d As LongDim isLens As BooleanApplication.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualSet ws1 = Worksheets("测试记录")Set ws2 = Worksheets("机台分析")Set dict = CreateObject("Scripting.Dictionary")' 清除旧数据ws2.Range("A3:AI1000").ClearContents' 获取日期范围startDate = ws2.Range("L1").ValueendDate = ws2.Range("P1").Value' 判断分析模式isLens = (ws2.Range("T1").Value = "镜片")' 步骤1：提取不重复的机台lastRow1 = ws1.Cells(ws1.Rows.count, "A").End(xlUp).Rowk = 3 ' 从第3行开始写入For i = 3 To lastRow1If ws1.Cells(i, 1).Value >= startDate And ws1.Cells(i, 1).Value <= endDate Then' 根据模式判断件号条件If (isLens And ws1.Cells(i, 8).Value > 800) Or _(Not isLens And ws1.Cells(i, 8).Value < 800) Thenkey = ws1.Cells(i, 5).Value ' 机台If Not dict.exists(key) Thendict.Add key, kws2.Cells(k, 3).Value = key ' 机台k = k + 1End IfEnd IfEnd IfNext i' 步骤2-9：计算各项指标lastRow2 = ws2.Cells(ws2.Rows.count, "C").End(xlUp).RowFor i = 3 To lastRow2' 初始化合计数据c = 0d = 0' 遍历日期列For dateCol = 5 To 35 ' E到AI列If ws2.Cells(2, dateCol).Value >= startDate And ws2.Cells(2, dateCol).Value <= endDate Then' 初始化每日数据a = 0b = 0' 遍历测试记录For j = 3 To lastRow1If ws1.Cells(j, 1).Value = ws2.Cells(2, dateCol).Value ThenIf ws1.Cells(j, 5).Value = ws2.Cells(i, 3).Value Then' 步骤2/7：总测试数a = a + 1c = c + 1' 步骤5/8：NG数If ws1.Cells(j, 11).Value = "NG" Thenb = b + 1d = d + 1End IfEnd IfEnd IfNext j' 步骤6：计算每日通过率If a > 0 Thenws2.Cells(i, dateCol).Value = Round((a - b) / a, 3)ws2.Cells(i, dateCol).NumberFormat = "0.0%"End IfEnd IfNext dateCol' 步骤9：计算合计通过率If c > 0 Thenws2.Cells(i, 4).Value = Round((c - d) / c, 3)ws2.Cells(i, 4).NumberFormat = "0.0%"End IfNext i' 步骤10：按通过率升序排序With ws2.Sort.SortFields.Clear.SortFields.Add key:=Range("D3:D" & lastRow2), SortOn:=xlSortOnValues, Order:=xlAscending.SetRange Range("C3:AI" & lastRow2).Header = xlNo.ApplyEnd WithApplication.Calculation = xlCalculationAutomaticApplication.ScreenUpdating = TrueMsgBox "机台通过率分析完成！当前模式：" & ws2.Range("T1").Value, vbInformation
End Sub

2.镜片通过率圈数分析

Option ExplicitSub AnalyzeLensPassRate()Dim ws1 As Worksheet, ws2 As WorksheetDim lastRow1 As Long, lastRow2 As LongDim startDate As Date, endDate As DateDim dict As Object, key As StringDim i As Long, j As Long, k As LongDim dateCol As LongDim a As Long, b As Long, c As Long, d As LongDim posCount As LongApplication.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualSet ws1 = Worksheets("测试记录")Set ws2 = Worksheets("镜片通过率圈数分析")Set dict = CreateObject("Scripting.Dictionary")' 步骤0：清除旧数据ws2.Range("A3:AL1000").ClearContents' 获取日期范围startDate = ws2.Range("L1").ValueendDate = ws2.Range("P1").Value' 步骤1：提取不重复的机种和件号组合lastRow1 = ws1.Cells(ws1.Rows.count, "A").End(xlUp).Rowk = 3 ' 从第3行开始写入For i = 3 To lastRow1If ws1.Cells(i, 1).Value >= startDate And ws1.Cells(i, 1).Value <= endDate ThenIf ws1.Cells(i, 8).Value > 800 Thenkey = ws1.Cells(i, 7).Value & "|" & ws1.Cells(i, 8).ValueIf Not dict.exists(key) Thendict.Add key, kws2.Cells(k, 2).Value = ws1.Cells(i, 7).Value ' 机种ws2.Cells(k, 3).Value = ws1.Cells(i, 8).Value ' 件号k = k + 1End IfEnd IfEnd IfNext i' 步骤2：填充客户工艺lastRow2 = ws2.Cells(ws2.Rows.count, "B").End(xlUp).RowFor i = 3 To lastRow2For j = 3 To lastRow1If ws1.Cells(j, 1).Value >= startDate And ws1.Cells(j, 1).Value <= endDate ThenIf ws1.Cells(j, 7).Value = ws2.Cells(i, 2).Value And _ws1.Cells(j, 8).Value = ws2.Cells(i, 3).Value Thenws2.Cells(i, 1).Value = ws1.Cells(j, 18).Value ' 客户工艺Exit ForEnd IfEnd IfNext jNext i' 步骤3：排序With ws2.Sort.SortFields.Clear.SortFields.Add key:=Range("A3:A" & lastRow2), SortOn:=xlSortOnValues, Order:=xlAscending.SortFields.Add key:=Range("B3:B" & lastRow2), SortOn:=xlSortOnValues, Order:=xlAscending.SetRange Range("A3:AP" & lastRow2).Header = xlNo.ApplyEnd With' 步骤4-12：计算各项指标For i = 3 To lastRow2' 初始化合计数据c = 0d = 0' 遍历日期列For dateCol = 5 To 35 ' E到AI列If ws2.Cells(2, dateCol).Value >= startDate And ws2.Cells(2, dateCol).Value <= endDate Then' 初始化每日数据a = 0b = 0' 遍历测试记录For j = 3 To lastRow1If ws1.Cells(j, 1).Value = ws2.Cells(2, dateCol).Value ThenIf ws1.Cells(j, 7).Value = ws2.Cells(i, 2).Value And _ws1.Cells(j, 8).Value = ws2.Cells(i, 3).Value Then' 步骤4/7：总测试数（整罩计3）a = a + 3c = c + 3' 步骤5/8：NG数（按位置计数）If ws1.Cells(j, 11).Value = "NG" ThenposCount = 0If InStr(ws1.Cells(j, 14).Value, "上") > 0 Then posCount = posCount + 1If InStr(ws1.Cells(j, 14).Value, "中") > 0 Then posCount = posCount + 1If InStr(ws1.Cells(j, 14).Value, "下") > 0 Then posCount = posCount + 1If InStr(ws1.Cells(j, 14).Value, "整罩") > 0 Then posCount = posCount + 3b = b + posCountd = d + posCount' 步骤10-12：特定异常项目计数（含位置计数）If InStr(ws1.Cells(j, 12).Value, "LAB") > 0 Thenws2.Cells(i, 36).Value = ws2.Cells(i, 36).Value + posCount ' AJ列End IfIf InStr(ws1.Cells(j, 12).Value, "膜色") > 0 Thenws2.Cells(i, 37).Value = ws2.Cells(i, 37).Value + posCount ' AK列End IfIf InStr(ws1.Cells(j, 12).Value, "反射率") > 0 Thenws2.Cells(i, 38).Value = ws2.Cells(i, 38).Value + posCount ' AL列End IfEnd IfEnd IfEnd IfNext j' 步骤6：计算每日通过率If a > 0 Thenws2.Cells(i, dateCol).Value = Round((a - b) / a, 3)ws2.Cells(i, dateCol).NumberFormat = "0.0%"End IfEnd IfNext dateCol' 步骤9：计算合计通过率If c > 0 Thenws2.Cells(i, 4).Value = Round((c - d) / c, 3)ws2.Cells(i, 4).NumberFormat = "0.0%"End IfNext iApplication.Calculation = xlCalculationAutomaticApplication.ScreenUpdating = TrueMsgBox "镜片通过率圈数分析完成！", vbInformation
End Sub

3.镜片通过率罩次分析

Option ExplicitSub AnalyzeLensPassRate()Dim ws1 As Worksheet, ws2 As WorksheetDim lastRow1 As Long, lastRow2 As LongDim startDate As Date, endDate As DateDim dict As Object, key As StringDim i As Long, j As Long, k As LongDim dateCol As LongDim a As Long, b As Long, c As Long, d As LongDim upCount As Long, midCount As Long, downCount As Long, fullCount As LongApplication.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualSet ws1 = Worksheets("测试记录")Set ws2 = Worksheets("镜片通过率罩次分析")Set dict = CreateObject("Scripting.Dictionary")' 清除旧数据ws2.Range("A3:AP1000").ClearContents' 获取日期范围startDate = ws2.Range("L1").ValueendDate = ws2.Range("P1").Value' 步骤1：提取不重复的机种和件号组合lastRow1 = ws1.Cells(ws1.Rows.count, "A").End(xlUp).Rowk = 3 ' 从第3行开始写入For i = 3 To lastRow1If ws1.Cells(i, 1).Value >= startDate And ws1.Cells(i, 1).Value <= endDate ThenIf ws1.Cells(i, 8).Value > 800 Thenkey = ws1.Cells(i, 7).Value & "|" & ws1.Cells(i, 8).ValueIf Not dict.exists(key) Thendict.Add key, kws2.Cells(k, 2).Value = ws1.Cells(i, 7).Value ' 机种ws2.Cells(k, 3).Value = ws1.Cells(i, 8).Value ' 件号k = k + 1End IfEnd IfEnd IfNext i' 步骤2：填充客户工艺lastRow2 = ws2.Cells(ws2.Rows.count, "B").End(xlUp).RowFor i = 3 To lastRow2For j = 3 To lastRow1If ws1.Cells(j, 1).Value >= startDate And ws1.Cells(j, 1).Value <= endDate ThenIf ws1.Cells(j, 7).Value = ws2.Cells(i, 2).Value And _ws1.Cells(j, 8).Value = ws2.Cells(i, 3).Value Thenws2.Cells(i, 1).Value = ws1.Cells(j, 18).Value ' 客户工艺Exit ForEnd IfEnd IfNext jNext i' 步骤3：排序With ws2.Sort.SortFields.Clear.SortFields.Add key:=Range("A3:A" & lastRow2), SortOn:=xlSortOnValues, Order:=xlAscending.SortFields.Add key:=Range("B3:B" & lastRow2), SortOn:=xlSortOnValues, Order:=xlAscending.SetRange Range("A3:AP" & lastRow2).Header = xlNo.ApplyEnd With' 步骤4-16：计算各项指标For i = 3 To lastRow2' 初始化合计数据c = 0d = 0upCount = 0midCount = 0downCount = 0fullCount = 0' 遍历日期列For dateCol = 5 To 35 ' E到AI列If ws2.Cells(2, dateCol).Value >= startDate And ws2.Cells(2, dateCol).Value <= endDate Then' 初始化每日数据a = 0b = 0' 遍历测试记录For j = 3 To lastRow1If ws1.Cells(j, 1).Value = ws2.Cells(2, dateCol).Value ThenIf ws1.Cells(j, 7).Value = ws2.Cells(i, 2).Value And _ws1.Cells(j, 8).Value = ws2.Cells(i, 3).Value Then' 步骤4/7：总测试数a = a + 1c = c + 1' 步骤5/8：NG数If ws1.Cells(j, 11).Value = "NG" Thenb = b + 1d = d + 1' 步骤10-12：特定异常项目计数If InStr(ws1.Cells(j, 12).Value, "LAB") > 0 Thenws2.Cells(i, 36).Value = ws2.Cells(i, 36).Value + 1 ' AJ列End IfIf InStr(ws1.Cells(j, 12).Value, "膜色") > 0 Thenws2.Cells(i, 37).Value = ws2.Cells(i, 37).Value + 1 ' AK列End IfIf InStr(ws1.Cells(j, 12).Value, "反射率") > 0 Thenws2.Cells(i, 38).Value = ws2.Cells(i, 38).Value + 1 ' AL列End If' 步骤13-16：位置统计If InStr(ws1.Cells(j, 14).Value, "上") > 0 Then upCount = upCount + 1If InStr(ws1.Cells(j, 14).Value, "中") > 0 Then midCount = midCount + 1If InStr(ws1.Cells(j, 14).Value, "下") > 0 Then downCount = downCount + 1If InStr(ws1.Cells(j, 14).Value, "整罩") > 0 Then fullCount = fullCount + 1End IfEnd IfEnd IfNext j' 步骤6：计算每日通过率If a > 0 Thenws2.Cells(i, dateCol).Value = Round((a - b) / a, 3)ws2.Cells(i, dateCol).NumberFormat = "0.0%"End IfEnd IfNext dateCol' 步骤9：计算合计通过率If c > 0 Thenws2.Cells(i, 4).Value = Round((c - d) / c, 3)ws2.Cells(i, 4).NumberFormat = "0.0%"End If' 步骤13-16：计算位置比例Dim total As Longtotal = upCount + midCount + downCount + fullCountIf total > 0 Thenws2.Cells(i, 39).Value = Round(upCount / total, 3) ' AM列ws2.Cells(i, 40).Value = Round(midCount / total, 3) ' AN列ws2.Cells(i, 41).Value = Round(downCount / total, 3) ' AO列ws2.Cells(i, 42).Value = Round(fullCount / total, 3) ' AP列' 设置百分比格式For j = 39 To 42ws2.Cells(i, j).NumberFormat = "0.0%"Next jEnd IfNext iApplication.Calculation = xlCalculationAutomaticApplication.ScreenUpdating = TrueMsgBox "分析完成!", vbInformation
End Sub

4.镜筒通过率圈数分析

Option ExplicitSub AnalyzeLensPassRate()Dim ws1 As Worksheet, ws2 As WorksheetDim lastRow1 As Long, lastRow2 As LongDim startDate As Date, endDate As DateDim dict As Object, key As StringDim i As Long, j As Long, k As LongDim dateCol As LongDim a As Long, b As Long, c As Long, d As LongDim posCount As LongApplication.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualSet ws1 = Worksheets("测试记录")Set ws2 = Worksheets("镜筒通过率圈数分析")Set dict = CreateObject("Scripting.Dictionary")' 步骤0：清除旧数据ws2.Range("A3:AL1000").ClearContents' 获取日期范围startDate = ws2.Range("L1").ValueendDate = ws2.Range("P1").Value' 步骤1：提取不重复的机种和件号组合lastRow1 = ws1.Cells(ws1.Rows.count, "A").End(xlUp).Rowk = 3 ' 从第3行开始写入For i = 3 To lastRow1If ws1.Cells(i, 1).Value >= startDate And ws1.Cells(i, 1).Value <= endDate ThenIf ws1.Cells(i, 8).Value < 800 Thenkey = ws1.Cells(i, 7).Value & "|" & ws1.Cells(i, 8).ValueIf Not dict.exists(key) Thendict.Add key, kws2.Cells(k, 2).Value = ws1.Cells(i, 7).Value ' 机种ws2.Cells(k, 3).Value = ws1.Cells(i, 8).Value ' 件号k = k + 1End IfEnd IfEnd IfNext i' 步骤2：填充客户工艺lastRow2 = ws2.Cells(ws2.Rows.count, "B").End(xlUp).RowFor i = 3 To lastRow2For j = 3 To lastRow1If ws1.Cells(j, 1).Value >= startDate And ws1.Cells(j, 1).Value <= endDate ThenIf ws1.Cells(j, 7).Value = ws2.Cells(i, 2).Value And _ws1.Cells(j, 8).Value = ws2.Cells(i, 3).Value Thenws2.Cells(i, 1).Value = ws1.Cells(j, 18).Value ' 客户工艺Exit ForEnd IfEnd IfNext jNext i' 步骤3：排序With ws2.Sort.SortFields.Clear.SortFields.Add key:=Range("A3:A" & lastRow2), SortOn:=xlSortOnValues, Order:=xlAscending.SortFields.Add key:=Range("B3:B" & lastRow2), SortOn:=xlSortOnValues, Order:=xlAscending.SetRange Range("A3:AP" & lastRow2).Header = xlNo.ApplyEnd With' 步骤4-12：计算各项指标For i = 3 To lastRow2' 初始化合计数据c = 0d = 0' 遍历日期列For dateCol = 5 To 35 ' E到AI列If ws2.Cells(2, dateCol).Value >= startDate And ws2.Cells(2, dateCol).Value <= endDate Then' 初始化每日数据a = 0b = 0' 遍历测试记录For j = 3 To lastRow1If ws1.Cells(j, 1).Value = ws2.Cells(2, dateCol).Value ThenIf ws1.Cells(j, 7).Value = ws2.Cells(i, 2).Value And _ws1.Cells(j, 8).Value = ws2.Cells(i, 3).Value Then' 步骤4/7：总测试数（整罩计3）a = a + 3c = c + 3' 步骤5/8：NG数（按位置计数）If ws1.Cells(j, 11).Value = "NG" ThenposCount = 0If InStr(ws1.Cells(j, 14).Value, "上") > 0 Then posCount = posCount + 1If InStr(ws1.Cells(j, 14).Value, "中") > 0 Then posCount = posCount + 1If InStr(ws1.Cells(j, 14).Value, "下") > 0 Then posCount = posCount + 1If InStr(ws1.Cells(j, 14).Value, "整罩") > 0 Then posCount = posCount + 3b = b + posCountd = d + posCount' 步骤10-12：特定异常项目计数（含位置计数）If InStr(ws1.Cells(j, 12).Value, "LAB") > 0 Thenws2.Cells(i, 36).Value = ws2.Cells(i, 36).Value + posCount ' AJ列End IfIf InStr(ws1.Cells(j, 12).Value, "膜色") > 0 Thenws2.Cells(i, 37).Value = ws2.Cells(i, 37).Value + posCount ' AK列End IfIf InStr(ws1.Cells(j, 12).Value, "反射率") > 0 Thenws2.Cells(i, 38).Value = ws2.Cells(i, 38).Value + posCount ' AL列End IfEnd IfEnd IfEnd IfNext j' 步骤6：计算每日通过率If a > 0 Thenws2.Cells(i, dateCol).Value = Round((a - b) / a, 3)ws2.Cells(i, dateCol).NumberFormat = "0.0%"End IfEnd IfNext dateCol' 步骤9：计算合计通过率If c > 0 Thenws2.Cells(i, 4).Value = Round((c - d) / c, 3)ws2.Cells(i, 4).NumberFormat = "0.0%"End IfNext iApplication.Calculation = xlCalculationAutomaticApplication.ScreenUpdating = TrueMsgBox "镜筒通过率圈数分析完成！", vbInformation
End Sub

5.镜筒通过率罩次分析

Option ExplicitSub AnalyzeLensPassRate()Dim ws1 As Worksheet, ws2 As WorksheetDim lastRow1 As Long, lastRow2 As LongDim startDate As Date, endDate As DateDim dict As Object, key As StringDim i As Long, j As Long, k As LongDim dateCol As LongDim a As Long, b As Long, c As Long, d As LongDim upCount As Long, midCount As Long, downCount As Long, fullCount As LongApplication.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualSet ws1 = Worksheets("测试记录")Set ws2 = Worksheets("镜筒通过率罩次分析")Set dict = CreateObject("Scripting.Dictionary")' 清除旧数据ws2.Range("A3:AP1000").ClearContents' 获取日期范围startDate = ws2.Range("L1").ValueendDate = ws2.Range("P1").Value' 步骤1：提取不重复的机种和件号组合lastRow1 = ws1.Cells(ws1.Rows.count, "A").End(xlUp).Rowk = 3 ' 从第3行开始写入For i = 3 To lastRow1If ws1.Cells(i, 1).Value >= startDate And ws1.Cells(i, 1).Value <= endDate ThenIf ws1.Cells(i, 8).Value < 800 Thenkey = ws1.Cells(i, 7).Value & "|" & ws1.Cells(i, 8).ValueIf Not dict.exists(key) Thendict.Add key, kws2.Cells(k, 2).Value = ws1.Cells(i, 7).Value ' 机种ws2.Cells(k, 3).Value = ws1.Cells(i, 8).Value ' 件号k = k + 1End IfEnd IfEnd IfNext i' 步骤2：填充客户工艺lastRow2 = ws2.Cells(ws2.Rows.count, "B").End(xlUp).RowFor i = 3 To lastRow2For j = 3 To lastRow1If ws1.Cells(j, 1).Value >= startDate And ws1.Cells(j, 1).Value <= endDate ThenIf ws1.Cells(j, 7).Value = ws2.Cells(i, 2).Value And _ws1.Cells(j, 8).Value = ws2.Cells(i, 3).Value Thenws2.Cells(i, 1).Value = ws1.Cells(j, 18).Value ' 客户工艺Exit ForEnd IfEnd IfNext jNext i' 步骤3：排序With ws2.Sort.SortFields.Clear.SortFields.Add key:=Range("A3:A" & lastRow2), SortOn:=xlSortOnValues, Order:=xlAscending.SortFields.Add key:=Range("B3:B" & lastRow2), SortOn:=xlSortOnValues, Order:=xlAscending.SetRange Range("A3:AP" & lastRow2).Header = xlNo.ApplyEnd With' 步骤4-16：计算各项指标For i = 3 To lastRow2' 初始化合计数据c = 0d = 0upCount = 0midCount = 0downCount = 0fullCount = 0' 遍历日期列For dateCol = 5 To 35 ' E到AI列If ws2.Cells(2, dateCol).Value >= startDate And ws2.Cells(2, dateCol).Value <= endDate Then' 初始化每日数据a = 0b = 0' 遍历测试记录For j = 3 To lastRow1If ws1.Cells(j, 1).Value = ws2.Cells(2, dateCol).Value ThenIf ws1.Cells(j, 7).Value = ws2.Cells(i, 2).Value And _ws1.Cells(j, 8).Value = ws2.Cells(i, 3).Value Then' 步骤4/7：总测试数a = a + 1c = c + 1' 步骤5/8：NG数If ws1.Cells(j, 11).Value = "NG" Thenb = b + 1d = d + 1' 步骤10-12：特定异常项目计数If InStr(ws1.Cells(j, 12).Value, "LAB") > 0 Thenws2.Cells(i, 36).Value = ws2.Cells(i, 36).Value + 1 ' AJ列End IfIf InStr(ws1.Cells(j, 12).Value, "膜色") > 0 Thenws2.Cells(i, 37).Value = ws2.Cells(i, 37).Value + 1 ' AK列End IfIf InStr(ws1.Cells(j, 12).Value, "反射率") > 0 Thenws2.Cells(i, 38).Value = ws2.Cells(i, 38).Value + 1 ' AL列End If' 步骤13-16：位置统计If InStr(ws1.Cells(j, 14).Value, "上") > 0 Then upCount = upCount + 1If InStr(ws1.Cells(j, 14).Value, "中") > 0 Then midCount = midCount + 1If InStr(ws1.Cells(j, 14).Value, "下") > 0 Then downCount = downCount + 1If InStr(ws1.Cells(j, 14).Value, "整罩") > 0 Then fullCount = fullCount + 1End IfEnd IfEnd IfNext j' 步骤6：计算每日通过率If a > 0 Thenws2.Cells(i, dateCol).Value = Round((a - b) / a, 3)ws2.Cells(i, dateCol).NumberFormat = "0.0%"End IfEnd IfNext dateCol' 步骤9：计算合计通过率If c > 0 Thenws2.Cells(i, 4).Value = Round((c - d) / c, 3)ws2.Cells(i, 4).NumberFormat = "0.0%"End If' 步骤13-16：计算位置比例Dim total As Longtotal = upCount + midCount + downCount + fullCountIf total > 0 Thenws2.Cells(i, 39).Value = Round(upCount / total, 3) ' AM列ws2.Cells(i, 40).Value = Round(midCount / total, 3) ' AN列ws2.Cells(i, 41).Value = Round(downCount / total, 3) ' AO列ws2.Cells(i, 42).Value = Round(fullCount / total, 3) ' AP列' 设置百分比格式For j = 39 To 42ws2.Cells(i, j).NumberFormat = "0.0%"Next jEnd IfNext iApplication.Calculation = xlCalculationAutomaticApplication.ScreenUpdating = TrueMsgBox "分析完成!", vbInformation
End Sub

6.客户工艺匹配

Sub MatchProcessAndClient()Dim ws1 As Worksheet, ws2 As WorksheetDim lastRow1 As Long, lastRow2 As LongDim dict As Object, key As StringDim notFoundList As StringDim i As Long' 设置工作表对象Set ws1 = Worksheets("测试记录")Set ws2 = Worksheets("工艺&客户整理")Set dict = CreateObject("Scripting.Dictionary")' 构建机种件号字典lastRow2 = ws2.Cells(ws2.Rows.count, "A").End(xlUp).RowFor i = 3 To lastRow2key = ws2.Cells(i, 1).Value & "|" & ws2.Cells(i, 2).ValueIf Not dict.exists(key) Thendict.Add key, Array(ws2.Cells(i, 3).Value, ws2.Cells(i, 4).Value)End IfNext i' 匹配数据并填充lastRow1 = ws1.Cells(ws1.Rows.count, "G").End(xlUp).RownotFoundList = ""For i = 3 To lastRow1key = ws1.Cells(i, 7).Value & "|" & ws1.Cells(i, 8).ValueIf dict.exists(key) Then' 匹配成功，填充工艺和客户ws1.Cells(i, 18).Value = dict(key)(0) 'R列客户工艺ws1.Cells(i, 19).Value = dict(key)(1) 'S列客户Else' 未匹配，填充提示信息ws1.Cells(i, 18).Value = "请维护该机种工艺"ws1.Cells(i, 19).Value = "请维护该机种客户"notFoundList = notFoundList & key & vbCrLfEnd IfNext i' 显示未匹配项If notFoundList <> "" ThenMsgBox "以下机种&件号未找到匹配项：" & vbCrLf & notFoundList, vbInformation, "匹配结果"ElseMsgBox "所有机种&件号均匹配成功！", vbInformation, "匹配结果"End If
End Sub

7.整体通过率

Sub CalculateTestStats()Dim ws1 As Worksheet, ws2 As WorksheetDim lastRow As Long, i As Long, j As LongDim dateRange As Range, cell As RangeDim totalCount As Long, okCount As Long, ngCount As LongDim labCount As Long, colorCount As Long, reflectCount As LongDim posCount As Long, totalPosCount As LongDim labPosCount As Long, colorPosCount As Long, reflectPosCount As Long' 设置工作表引用Set ws1 = Worksheets("测试记录")Set ws2 = Worksheets("整体通过率")Set dateRange = ws2.Range("E2:AI2")' 清空结果区域ws2.Range("E3:AI16").ClearContentsws2.Range("D3:D16").ClearContentsws2.Range("E19:AI32").ClearContentsws2.Range("D19:D32").ClearContents' 获取最后数据行lastRow = ws1.Cells(ws1.Rows.count, 1).End(xlUp).Row' 主统计循环For Each cell In dateRange' 1. 统计总测试批次totalCount = Application.CountIf(ws1.Columns(1), cell.Value)ws2.Cells(3, cell.Column).Value = IIf(totalCount = 0, "", totalCount)' 2. 统计OK批次okCount = Application.CountIfs(ws1.Columns(1), cell.Value, ws1.Columns(11), "OK")ws2.Cells(4, cell.Column).Value = IIf(okCount = 0, "", okCount)' 3. 统计NG批次ngCount = Application.CountIfs(ws1.Columns(1), cell.Value, ws1.Columns(11), "NG")ws2.Cells(5, cell.Column).Value = IIf(ngCount = 0, "", ngCount)' 4. 计算流通率If totalCount > 0 And okCount > 0 Thenws2.Cells(6, cell.Column).Value = Format(okCount / totalCount, "0.0%")Elsews2.Cells(6, cell.Column).Value = ""End If' 5. 统计各类异常labCount = 0: colorCount = 0: reflectCount = 0posCount = 0: totalPosCount = 0labPosCount = 0: colorPosCount = 0: reflectPosCount = 0For i = 3 To lastRowIf ws1.Cells(i, 1).Value = cell.Value ThenIf ws1.Cells(i, 11).Value = "NG" Then' 5.1 Lab异常If InStr(1, ws1.Cells(i, 12).Value, "LAB") > 0 ThenlabCount = labCount + 1' 14. Lab异常且位置异常posCount = GetPositionCount(ws1.Cells(i, 14).Value)labPosCount = labPosCount + posCountEnd If' 5.2 膜色异常If InStr(1, ws1.Cells(i, 12).Value, "膜色") > 0 ThencolorCount = colorCount + 1' 15. 膜色异常且位置异常posCount = GetPositionCount(ws1.Cells(i, 14).Value)colorPosCount = colorPosCount + posCountEnd If' 5.3 反射率异常If InStr(1, ws1.Cells(i, 12).Value, "反射率") > 0 ThenreflectCount = reflectCount + 1' 16. 反射率异常且位置异常posCount = GetPositionCount(ws1.Cells(i, 14).Value)reflectPosCount = reflectPosCount + posCountEnd If' 12. 位置异常统计posCount = GetPositionCount(ws1.Cells(i, 14).Value)totalPosCount = totalPosCount + posCountEnd IfEnd IfNext' 输出各类异常统计结果ws2.Cells(7, cell.Column).Value = IIf(labCount = 0, "", labCount)        ' Lab异常ws2.Cells(8, cell.Column).Value = IIf(colorCount = 0, "", colorCount)    ' 膜色异常ws2.Cells(9, cell.Column).Value = IIf(reflectCount = 0, "", reflectCount) ' 反射率异常' 10. 总测试数×3ws2.Cells(10, cell.Column).Value = IIf(totalCount = 0, "", totalCount * 3)' 11. (总测试数×3) - 位置异常字数ws2.Cells(11, cell.Column).Value = IIf(totalCount = 0, "", (totalCount * 3) - totalPosCount)' 12. 位置异常字数ws2.Cells(12, cell.Column).Value = IIf(totalPosCount = 0, "", totalPosCount)' 13. 计算通过率 (D11/D10)If ws2.Cells(10, cell.Column).Value <> 0 And ws2.Cells(11, cell.Column).Value <> "" Thenws2.Cells(13, cell.Column).Value = Format(ws2.Cells(11, cell.Column).Value / ws2.Cells(10, cell.Column).Value, "0.0%")Elsews2.Cells(13, cell.Column).Value = ""End If' 14-16. 输出带位置信息的异常统计ws2.Cells(14, cell.Column).Value = IIf(labPosCount = 0, "", labPosCount)      ' Lab异常+位置ws2.Cells(15, cell.Column).Value = IIf(colorPosCount = 0, "", colorPosCount)  ' 膜色异常+位置ws2.Cells(16, cell.Column).Value = IIf(reflectPosCount = 0, "", reflectPosCount) ' 反射率异常+位置Next' 计算各列的合计值ws2.Range("D3").Value = Application.Sum(ws2.Range("E3:AI3"))    ' 总测试批次ws2.Range("D4").Value = Application.Sum(ws2.Range("E4:AI4"))    ' OK批次ws2.Range("D5").Value = Application.Sum(ws2.Range("E5:AI5"))    ' NG批次' 计算总流通率If ws2.Range("D3").Value <> 0 And ws2.Range("D4").Value <> 0 Thenws2.Range("D6").Value = Format(ws2.Range("D4").Value / ws2.Range("D3").Value, "0.0%")Elsews2.Range("D6").Value = ""End Ifws2.Range("D7").Value = Application.Sum(ws2.Range("E7:AI7"))    ' Lab异常ws2.Range("D8").Value = Application.Sum(ws2.Range("E8:AI8"))    ' 膜色异常ws2.Range("D9").Value = Application.Sum(ws2.Range("E9:AI9"))    ' 反射率异常ws2.Range("D10").Value = ws2.Range("D3").Value * 3              ' 总测试数×3' 计算总位置异常字数totalPosCount = 0For i = 3 To lastRowIf ws1.Cells(i, 11).Value = "NG" ThentotalPosCount = totalPosCount + GetPositionCount(ws1.Cells(i, 14).Value)End IfNextws2.Range("D12").Value = IIf(totalPosCount = 0, "", totalPosCount)' 计算(D11) = (D10) - (D12)ws2.Range("D11").Value = ws2.Range("D10").Value - ws2.Range("D12").Value' 计算总通过率 (D11/D10)If ws2.Range("D10").Value <> 0 And ws2.Range("D11").Value <> "" Thenws2.Range("D13").Value = Format(ws2.Range("D11").Value / ws2.Range("D10").Value, "0.0%")Elsews2.Range("D13").Value = ""End If' 计算带位置信息的异常合计ws2.Range("D14").Value = Application.Sum(ws2.Range("E14:AI14"))  ' Lab异常+位置ws2.Range("D15").Value = Application.Sum(ws2.Range("E15:AI15"))  ' 膜色异常+位置ws2.Range("D16").Value = Application.Sum(ws2.Range("E16:AI16"))  ' 反射率异常+位置' 主统计循环For Each cell In dateRange' 1. 统计总测试批次(H列<800)totalCount = 0For i = 3 To lastRowIf ws1.Cells(i, 1).Value = cell.Value And ws1.Cells(i, 8).Value < 800 ThentotalCount = totalCount + 1End IfNextws2.Cells(19, cell.Column).Value = IIf(totalCount = 0, "", totalCount)' 2. 统计OK批次(H列<800)okCount = 0For i = 3 To lastRowIf ws1.Cells(i, 1).Value = cell.Value And ws1.Cells(i, 8).Value < 800 And ws1.Cells(i, 11).Value = "OK" ThenokCount = okCount + 1End IfNextws2.Cells(20, cell.Column).Value = IIf(okCount = 0, "", okCount)' 3. 统计NG批次(H列<800)ngCount = 0For i = 3 To lastRowIf ws1.Cells(i, 1).Value = cell.Value And ws1.Cells(i, 8).Value < 800 And ws1.Cells(i, 11).Value = "NG" ThenngCount = ngCount + 1End IfNextws2.Cells(21, cell.Column).Value = IIf(ngCount = 0, "", ngCount)' 4. 计算流通率If totalCount > 0 And okCount > 0 Thenws2.Cells(22, cell.Column).Value = Format(okCount / totalCount, "0.0%")Elsews2.Cells(22, cell.Column).Value = ""End If' 5. 统计各类异常(H列<800)labCount = 0: colorCount = 0: reflectCount = 0posCount = 0: totalPosCount = 0For i = 3 To lastRowIf ws1.Cells(i, 1).Value = cell.Value And ws1.Cells(i, 8).Value < 800 And ws1.Cells(i, 11).Value = "NG" Then' 5.1 Lab异常If InStr(1, ws1.Cells(i, 12).Value, "LAB") > 0 ThenlabCount = labCount + 1End If' 5.2 膜色异常If InStr(1, ws1.Cells(i, 12).Value, "膜色") > 0 ThencolorCount = colorCount + 1End If' 5.3 反射率异常If InStr(1, ws1.Cells(i, 12).Value, "反射率") > 0 ThenreflectCount = reflectCount + 1End If' 位置异常统计posCount = GetPositionCount(ws1.Cells(i, 14).Value)totalPosCount = totalPosCount + posCountEnd IfNext' 输出各类异常统计结果ws2.Cells(23, cell.Column).Value = IIf(labCount = 0, "", labCount)ws2.Cells(24, cell.Column).Value = IIf(colorCount = 0, "", colorCount)ws2.Cells(25, cell.Column).Value = IIf(reflectCount = 0, "", reflectCount)' 6. 总测试数×3ws2.Cells(26, cell.Column).Value = IIf(totalCount = 0, "", totalCount * 3)' 7. (总测试数×3) - 位置异常字数ws2.Cells(27, cell.Column).Value = IIf(totalCount = 0, "", (totalCount * 3) - totalPosCount)' 8. 位置异常字数ws2.Cells(28, cell.Column).Value = IIf(totalPosCount = 0, "", totalPosCount)' 9. 计算通过率 (D27/D26)If ws2.Cells(26, cell.Column).Value <> 0 And ws2.Cells(27, cell.Column).Value <> "" Thenws2.Cells(29, cell.Column).Value = Format(ws2.Cells(27, cell.Column).Value / ws2.Cells(26, cell.Column).Value, "0.0%")Elsews2.Cells(29, cell.Column).Value = ""End If' 10. 带位置信息的异常统计'Dim labPosCount As Long, colorPosCount As Long, reflectPosCount As LonglabPosCount = 0: colorPosCount = 0: reflectPosCount = 0For i = 3 To lastRowIf ws1.Cells(i, 1).Value = cell.Value And ws1.Cells(i, 8).Value < 800 And ws1.Cells(i, 11).Value = "NG" ThenposCount = GetPositionCount(ws1.Cells(i, 14).Value)' 10.1 Lab异常+位置If InStr(1, ws1.Cells(i, 12).Value, "LAB") > 0 And posCount > 0 ThenlabPosCount = labPosCount + posCountEnd If' 10.2 膜色异常+位置If InStr(1, ws1.Cells(i, 12).Value, "膜色") > 0 And posCount > 0 ThencolorPosCount = colorPosCount + posCountEnd If' 10.3 反射率异常+位置If InStr(1, ws1.Cells(i, 12).Value, "反射率") > 0 And posCount > 0 ThenreflectPosCount = reflectPosCount + posCountEnd IfEnd IfNextws2.Cells(30, cell.Column).Value = IIf(labPosCount = 0, "", labPosCount)ws2.Cells(31, cell.Column).Value = IIf(colorPosCount = 0, "", colorPosCount)ws2.Cells(32, cell.Column).Value = IIf(reflectPosCount = 0, "", reflectPosCount)Next' 计算各列的合计值ws2.Range("D19").Value = Application.Sum(ws2.Range("E19:AI19"))ws2.Range("D20").Value = Application.Sum(ws2.Range("E20:AI20"))ws2.Range("D21").Value = Application.Sum(ws2.Range("E21:AI21"))' 计算总流通率If ws2.Range("D19").Value <> 0 And ws2.Range("D20").Value <> 0 Thenws2.Range("D22").Value = Format(ws2.Range("D20").Value / ws2.Range("D19").Value, "0.0%")Elsews2.Range("D22").Value = ""End Ifws2.Range("D23").Value = Application.Sum(ws2.Range("E23:AI23"))ws2.Range("D24").Value = Application.Sum(ws2.Range("E24:AI24"))ws2.Range("D25").Value = Application.Sum(ws2.Range("E25:AI25"))ws2.Range("D26").Value = ws2.Range("D19").Value * 3' 计算总位置异常字数totalPosCount = 0For i = 3 To lastRowIf ws1.Cells(i, 8).Value < 800 And ws1.Cells(i, 11).Value = "NG" ThentotalPosCount = totalPosCount + GetPositionCount(ws1.Cells(i, 14).Value)End IfNextws2.Range("D28").Value = IIf(totalPosCount = 0, "", totalPosCount)' 计算(D27) = (D26) - (D28)ws2.Range("D27").Value = ws2.Range("D26").Value - ws2.Range("D28").Value' 计算总通过率 (D27/D26)If ws2.Range("D26").Value <> 0 And ws2.Range("D27").Value <> "" Thenws2.Range("D29").Value = Format(ws2.Range("D27").Value / ws2.Range("D26").Value, "0.0%")Elsews2.Range("D29").Value = ""End If' 计算带位置信息的异常合计ws2.Range("D30").Value = Application.Sum(ws2.Range("E30:AI30"))ws2.Range("D31").Value = Application.Sum(ws2.Range("E31:AI31"))ws2.Range("D32").Value = Application.Sum(ws2.Range("E32:AI32"))MsgBox "数据统计完成！", vbInformation
End SubFunction GetPositionCount(posText As String) As LongDim count As Longcount = 0If InStr(1, posText, "上") > 0 Then count = count + 1If InStr(1, posText, "中") > 0 Then count = count + 1If InStr(1, posText, "下") > 0 Then count = count + 1If InStr(1, posText, "整罩") > 0 Then count = count + 3GetPositionCount = count
End Function

总结

分享：
接受可以让我面对所有的问题，当我感到焦虑的时候，通常是因为我发现自己不能接受生活中的一些人、地方、事情，直到我完全接受了它们，我才能获得心灵上的安宁。除非我完全的接受生活，否则我将无法获得快乐。我不需要再纠结这个世界上有什么需要改变而是关注我自己的态度需要发生怎样的改变；