vba学习系列(12)--反射率通过率计算复杂度优化25/8/17

系列文章目录

---

前言

---

一、反射率通过率

1.整体通过率

vba 高速处理excel 10万行以上数据
sheet1名称为测试记录，第二行为标题行，A2列标题测试日期，B2列标题班次，C2列标题测试员，D2列标题测试仪，E2列标题机台，F2列标题罩次，G2列标题机种，H2列标题件号，K2列标题判定，L2列标题异常项目，N2列标题位置，U2列标题终端，V2列标题工艺
sheet2名称为整体通过率，第二行为标题行，C2标题为日期，D2标题为合计，E2：AI2分别为6/1-7/1日期
C3标题为总测试批次、C4标题为OK批次、C5标题为NG批次、C6标题为流通率、C7标题为Lab异常、C8标题为膜色异常、C9标题为反射率异常；C10：C16标题与C3:C9内容相同
vba实现以下功能：
1）清除sheet2 D3:AI16区域单元格内容
2）定义“上”、“中”、“下”为1，“上中”、“上下”、“中下”、“中上”、“下中”、“下上”为2，“整罩”为3
计数a=(sheet1 A3列日期 分别等于sheet2 L1起始日期至 P1终止日期且等于sheet2 E2:AI2 对应日期) ,输出到C3行，E2：AI2日期对应的列，并求和E3：AI3后输出到D3
计数b=(sheet1 A3列日期 分别等于sheet2 L1起始日期至 P1终止日期且等于sheet2 E2:AI2 对应日期 且sheet1 K3列为“OK”)，输出到C4行，E2：AI2日期对应的列，并求和E4：AI4后输出到D4
计数c=(sheet1 A3列日期 分别等于sheet2 L1起始日期至 P1终止日期且等于sheet2 E2:AI2 对应日期 且sheet1 K3列为“NG”)，输出到C5行，E2：AI2日期对应的列，并求和E5：AI5后输出到D5
计算d=b/a设置d2格式，百分比保留2位小数，输出到C6行，E2：AI2日期对应的列， 计算 d2为0或计算d2错误时输出空值且无填充颜色，d2值小于80%标红,d2值80%-90%标橙色，d2值90%-98%标黄，d2值98%以上标绿
计算D4/D3，输出到D6，百分比保留2位小数， 计算错误时输出空值且无填充颜色，小于80%标红,80%-90%标橙色，90%-98%标黄，98%以上标绿
计数e=(sheet1 A3列日期 分别等于sheet2 L1起始日期至 P1终止日期且等于sheet2 E2:AI2 对应日期 且sheet1 K3列为“NG”且sheet1 L3列内容包含“LAB”)，输出到C7行，E7：AI7日期对应的列，并求和E7：AI7后输出到D7
计数f=(sheet1 A3列日期 分别等于sheet2 L1起始日期至 P1终止日期且等于sheet2 E2:AI2 对应日期 且sheet1 K3列为“NG”且sheet1 L3列内容包含“膜色”)，输出到C8行，E8：AI8日期对应的列，并求和E8：AI8后输出到D8
计数g=(sheet1 A3列日期 分别等于sheet2 L1起始日期至 P1终止日期且等于sheet2 E2:AI2 对应日期 且sheet1 K3列为“NG”且sheet1 L3列内容包含“反射率”)，输出到C9行，E2：AI2日期对应的列，并求和E9：AI9后输出到D9
计数h=(sheet1 A3列日期 分别等于sheet2 L1起始日期至 P1终止日期且等于sheet2 E2:AI2 对应日期)*3 ,输出到C10行，E2：AI2日期对应的列，并求和E10：AI10后输出到D10
计数I=(sheet1 A3列日期 分别等于sheet2 L1起始日期至 P1终止日期且等于sheet2 E2:AI2 对应日期 且sheet1 K3列为“NG”且sheet1 N3列“上”、“中”、“下”、“上中”、“上下”、“中下”、“中上”、“下中”、“下上”、“整罩”的个数)，输出到C12行，E2：AI2日期对应的列，并求和E12：AI12后输出到D12
计算J=h-I，输出到C11行，E2：AI2日期对应的列，并求和E11：AI11后输出到D11
计算k=J/h 设置k格式，百分比保留2位小数，输出到C13行，E2：AI2日期对应的列， 计算 k为0或计算k错误时输出空值且无填充颜色，k值小于80%标红,k值80%-90%标橙色，k值90%-98%标黄，k值98%以上标绿
计算D11/D10，输出到D13，百分比保留2位小数， 计算错误时输出空值且无填充颜色，小于80%标红,80%-90%标橙色，90%-98%标黄，98%以上标绿
计数L=(sheet1 A3列日期 分别等于sheet2 L1起始日期至 P1终止日期且等于sheet2 E2:AI2 对应日期 且sheet1 K3列为“NG”且sheet1 L3列内容包含“LAB”且sheet1 N3列“上”、“中”、“下”、“上中”、“上下”、“中下”、“中上”、“下中”、“下上”、“整罩”的个数)，输出到C14行，E2：AI2日期对应的列，并求和E14：AI14后输出到D14
计数m=(sheet1 A3列日期 分别等于sheet2 L1起始日期至 P1终止日期且等于sheet2 E2:AI2 对应日期 且sheet1 K3列为“NG”且sheet1 L3列内容包含“膜色”且sheet1 N3列“上”、“中”、“下”、“上中”、“上下”、“中下”、“中上”、“下中”、“下上”、“整罩”的个数)，输出到C15行，E2：AI2日期对应的列，并求和E15：AI15后输出到D15
计数n=(sheet1 A3列日期 分别等于sheet2 L1起始日期至 P1终止日期且等于sheet2 E2:AI2 对应日期 且sheet1 K3列为“NG”且sheet1 L3列内容包含“反射率”且sheet1 N3列“上”、“中”、“下”、“上中”、“上下”、“中下”、“中上”、“下中”、“下上”、“整罩”的个数)，输出到C16行，E2：AI2日期对应的列，并求和E16：AI16后输出到D16

Option Explicit
Sub ProcessTestData()Dim ws1 As Worksheet, ws2 As WorksheetDim lastRow As Long, i As Long, j As LongDim startDate As Date, endDate As DateDim dict As ObjectDim key As Variant' 优化设置Application.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualApplication.EnableEvents = FalseSet ws1 = Worksheets("测试记录")Set ws2 = Worksheets("整体通过率")Set dict = CreateObject("Scripting.Dictionary")' 1. 清除目标区域ws2.Range("D3:AI16").ClearContentsws2.Range("D3:AI16").Interior.ColorIndex = xlNonews2.Range("D19:AI32").ClearContentsws2.Range("D19:AI32").Interior.ColorIndex = xlNonews2.Range("D35:AI48").ClearContentsws2.Range("D35:AI48").Interior.ColorIndex = xlNone' 获取日期范围startDate = ws2.Range("L1").valueendDate = ws2.Range("P1").value' 获取数据最后一行lastRow = ws1.Cells(ws1.Rows.count, "A").End(xlUp).row' 使用数组处理提高速度Dim dataArr As Variant, posArr As VariantdataArr = ws1.Range("A3:N" & lastRow).valueposArr = ws1.Range("N3:N" & lastRow).value' 预定义位置权重Dim posWeights As ObjectSet posWeights = CreateObject("Scripting.Dictionary")With posWeights.Add "上", 1: .Add "中", 1: .Add "下", 1.Add "上中", 2: .Add "上下", 2: .Add "中下", 2.Add "中上", 2: .Add "下中", 2: .Add "下上", 2.Add "整罩", 3End With' 初始化合计字典Dim totalDict As ObjectDim totalDict1 As ObjectDim totalDict2 As ObjectSet totalDict = CreateObject("Scripting.Dictionary")Set totalDict1 = CreateObject("Scripting.Dictionary")Set totalDict2 = CreateObject("Scripting.Dictionary")totalDict.Add "total", 0: totalDict.Add "ok", 0: totalDict.Add "ng", 0totalDict.Add "lab", 0: totalDict.Add "color", 0: totalDict.Add "reflect", 0totalDict.Add "posTotal", 0: totalDict.Add "posNG", 0totalDict.Add "labPos", 0: totalDict.Add "colorPos", 0: totalDict.Add "reflectPos", 0totalDict1.Add "total1", 0: totalDict1.Add "ok1", 0: totalDict1.Add "ng1", 0totalDict1.Add "lab1", 0: totalDict1.Add "color1", 0: totalDict1.Add "reflect1", 0totalDict1.Add "posTotal1", 0: totalDict1.Add "posNG1", 0totalDict1.Add "labPos1", 0: totalDict1.Add "colorPos1", 0: totalDict1.Add "reflectPos1", 0totalDict2.Add "total2", 0: totalDict2.Add "ok2", 0: totalDict2.Add "ng2", 0totalDict2.Add "lab2", 0: totalDict2.Add "color2", 0: totalDict2.Add "reflect2", 0totalDict2.Add "posTotal2", 0: totalDict2.Add "posNG2", 0totalDict2.Add "labPos2", 0: totalDict2.Add "colorPos2", 0: totalDict2.Add "reflectPos2", 0' 处理每个日期列-整体For j = 5 To 35 ' E到AI列If IsDate(ws2.Cells(2, j).value) ThenDim currentDate As DatecurrentDate = ws2.Cells(2, j).valueIf currentDate >= startDate And currentDate <= endDate ThenDim counts As ObjectSet counts = CreateObject("Scripting.Dictionary")counts.Add "total", 0: counts.Add "ok", 0: counts.Add "ng", 0counts.Add "lab", 0: counts.Add "color", 0: counts.Add "reflect", 0counts.Add "posTotal", 0: counts.Add "posNG", 0counts.Add "labPos", 0: counts.Add "colorPos", 0: counts.Add "reflectPos", 0' 遍历数据For i = LBound(dataArr) To UBound(dataArr)If dataArr(i, 1) = currentDate Thencounts("total") = counts("total") + 1counts("posTotal") = counts("posTotal") + 3 ' 每行默认3If dataArr(i, 11) = "OK" Thencounts("ok") = counts("ok") + 1ElseIf dataArr(i, 11) = "NG" Thencounts("ng") = counts("ng") + 1' 检查异常项目Dim exception As String, position As Stringexception = dataArr(i, 12) ' L列position = posArr(i, 1) ' N列' 位置计数If posWeights.Exists(position) Thencounts("posNG") = counts("posNG") + posWeights(position)End If' 特定异常计数If InStr(1, exception, "LAB", vbTextCompare) > 0 Thencounts("lab") = counts("lab") + 1If posWeights.Exists(position) Thencounts("labPos") = counts("labPos") + posWeights(position)End IfEnd IfIf InStr(1, exception, "膜色", vbTextCompare) > 0 Thencounts("color") = counts("color") + 1If posWeights.Exists(position) Thencounts("colorPos") = counts("colorPos") + posWeights(position)End IfEnd IfIf InStr(1, exception, "反射率", vbTextCompare) > 0 Thencounts("reflect") = counts("reflect") + 1If posWeights.Exists(position) Thencounts("reflectPos") = counts("reflectPos") + posWeights(position)End IfEnd IfEnd IfEnd IfNext i' 写入基础统计ws2.Cells(3, j).value = counts("total")ws2.Cells(4, j).value = counts("ok")ws2.Cells(5, j).value = counts("ng")' 写入位置相关统计ws2.Cells(10, j).value = counts("posTotal")ws2.Cells(12, j).value = counts("posNG")ws2.Cells(11, j).value = counts("posTotal") - counts("posNG")' 写入异常计数ws2.Cells(7, j).value = counts("lab")ws2.Cells(8, j).value = counts("color")ws2.Cells(9, j).value = counts("reflect")' 写入带位置的异常计数ws2.Cells(14, j).value = counts("labPos")ws2.Cells(15, j).value = counts("colorPos")ws2.Cells(16, j).value = counts("reflectPos")' 计算通过率并设置格式SetRateFormat ws2, j, 6, counts("ok"), counts("total") ' 流通率SetRateFormat ws2, j, 13, (counts("posTotal") - counts("posNG")), counts("posTotal") ' 位置通过率' 累加合计值For Each key In counts.keystotalDict(key) = totalDict(key) + counts(key)NextEnd IfEnd IfNext j' 处理每个日期列-镜筒For j = 5 To 35 ' E到AI列If IsDate(ws2.Cells(18, j).value) ThenDim currentDate1 As DatecurrentDate1 = ws2.Cells(18, j).valueIf currentDate1 >= startDate And currentDate1 <= endDate ThenDim counts1 As ObjectSet counts1 = CreateObject("Scripting.Dictionary")counts1.Add "total1", 0: counts1.Add "ok1", 0: counts1.Add "ng1", 0counts1.Add "lab1", 0: counts1.Add "color1", 0: counts1.Add "reflect1", 0counts1.Add "posTotal1", 0: counts1.Add "posNG1", 0counts1.Add "labPos1", 0: counts1.Add "colorPos1", 0: counts1.Add "reflectPos1", 0' 遍历数据For i = LBound(dataArr) To UBound(dataArr)If dataArr(i, 1) = currentDate1 And dataArr(i, 8) < 800 Thencounts1("total1") = counts1("total1") + 1counts1("posTotal1") = counts1("posTotal1") + 3 ' 每行默认3If dataArr(i, 11) = "OK" Thencounts1("ok1") = counts1("ok1") + 1ElseIf dataArr(i, 11) = "NG" Thencounts1("ng1") = counts1("ng1") + 1' 检查异常项目Dim exception1 As String, position1 As Stringexception1 = dataArr(i, 12) ' L列position1 = posArr(i, 1) ' N列' 位置计数If posWeights.Exists(position1) Thencounts1("posNG1") = counts1("posNG1") + posWeights(position1)End If' 特定异常计数If InStr(1, exception1, "LAB", vbTextCompare) > 0 Thencounts1("lab1") = counts1("lab1") + 1If posWeights.Exists(position1) Thencounts1("labPos1") = counts1("labPos1") + posWeights(position1)End IfEnd IfIf InStr(1, exception1, "膜色", vbTextCompare) > 0 Thencounts1("color1") = counts1("color1") + 1If posWeights.Exists(position1) Thencounts1("colorPos1") = counts1("colorPos1") + posWeights(position1)End IfEnd IfIf InStr(1, exception1, "反射率", vbTextCompare) > 0 Thencounts1("reflect1") = counts1("reflect1") + 1If posWeights.Exists(position1) Thencounts1("reflectPos1") = counts1("reflectPos1") + posWeights(position1)End IfEnd IfEnd IfEnd IfNext i' 写入基础统计ws2.Cells(19, j).value = counts1("total1")ws2.Cells(20, j).value = counts1("ok1")ws2.Cells(21, j).value = counts1("ng1")' 写入位置相关统计ws2.Cells(26, j).value = counts1("posTotal1")ws2.Cells(28, j).value = counts1("posNG1")ws2.Cells(27, j).value = counts1("posTotal1") - counts1("posNG1")' 写入异常计数ws2.Cells(23, j).value = counts1("lab1")ws2.Cells(24, j).value = counts1("color1")ws2.Cells(25, j).value = counts1("reflect1")' 写入带位置的异常计数ws2.Cells(30, j).value = counts1("labPos1")ws2.Cells(31, j).value = counts1("colorPos1")ws2.Cells(32, j).value = counts1("reflectPos1")' 计算通过率并设置格式SetRateFormat ws2, j, 22, counts1("ok1"), counts1("total1") ' 流通率SetRateFormat ws2, j, 29, (counts1("posTotal1") - counts1("posNG1")), counts1("posTotal1") ' 位置通过率' 累加合计值For Each key In counts1.keystotalDict1(key) = totalDict1(key) + counts1(key)NextEnd IfEnd IfNext j' 处理每个日期列-镜片For j = 5 To 35 ' E到AI列If IsDate(ws2.Cells(34, j).value) ThenDim currentDate2 As DatecurrentDate2 = ws2.Cells(34, j).valueIf currentDate2 >= startDate And currentDate2 <= endDate ThenDim counts2 As ObjectSet counts2 = CreateObject("Scripting.Dictionary")counts2.Add "total2", 0: counts2.Add "ok2", 0: counts2.Add "ng2", 0counts2.Add "lab2", 0: counts2.Add "color2", 0: counts2.Add "reflect2", 0counts2.Add "posTotal2", 0: counts2.Add "posNG2", 0counts2.Add "labPos2", 0: counts2.Add "colorPos2", 0: counts2.Add "reflectPos2", 0' 遍历数据For i = LBound(dataArr) To UBound(dataArr)If dataArr(i, 1) = currentDate2 And dataArr(i, 8) > 800 Thencounts2("total2") = counts2("total2") + 1counts2("posTotal2") = counts2("posTotal2") + 3 ' 每行默认3If dataArr(i, 11) = "OK" Thencounts2("ok2") = counts2("ok2") + 1ElseIf dataArr(i, 11) = "NG" Thencounts2("ng2") = counts2("ng2") + 1' 检查异常项目Dim exception2 As String, position2 As Stringexception2 = dataArr(i, 12) ' L列position2 = posArr(i, 1) ' N列' 位置计数If posWeights.Exists(position2) Thencounts2("posNG2") = counts2("posNG2") + posWeights(position2)End If' 特定异常计数If InStr(1, exception2, "LAB", vbTextCompare) > 0 Thencounts2("lab2") = counts2("lab2") + 1If posWeights.Exists(position2) Thencounts2("labPos2") = counts2("labPos2") + posWeights(position2)End IfEnd IfIf InStr(1, exception2, "膜色", vbTextCompare) > 0 Thencounts2("color2") = counts2("color2") + 1If posWeights.Exists(position2) Thencounts2("colorPos2") = counts2("colorPos2") + posWeights(position2)End IfEnd IfIf InStr(1, exception2, "反射率", vbTextCompare) > 0 Thencounts2("reflect2") = counts2("reflect2") + 1If posWeights.Exists(position2) Thencounts2("reflectPos2") = counts2("reflectPos2") + posWeights(position2)End IfEnd IfEnd IfEnd IfNext i' 写入基础统计ws2.Cells(35, j).value = counts2("total2")ws2.Cells(36, j).value = counts2("ok2")ws2.Cells(37, j).value = counts2("ng2")' 写入位置相关统计ws2.Cells(42, j).value = counts2("posTotal2")ws2.Cells(44, j).value = counts2("posNG2")ws2.Cells(43, j).value = counts2("posTotal2") - counts2("posNG2")' 写入异常计数ws2.Cells(39, j).value = counts2("lab2")ws2.Cells(40, j).value = counts2("color2")ws2.Cells(41, j).value = counts2("reflect2")' 写入带位置的异常计数ws2.Cells(46, j).value = counts2("labPos2")ws2.Cells(47, j).value = counts2("colorPos2")ws2.Cells(48, j).value = counts2("reflectPos2")' 计算通过率并设置格式SetRateFormat ws2, j, 38, counts2("ok2"), counts2("total2") ' 流通率SetRateFormat ws2, j, 45, (counts2("posTotal2") - counts2("posNG2")), counts2("posTotal2") ' 位置通过率' 累加合计值For Each key In counts2.keystotalDict2(key) = totalDict2(key) + counts2(key)NextEnd IfEnd IfNext j' 写入合计列ws2.Range("D3").value = totalDict("total")ws2.Range("D4").value = totalDict("ok")ws2.Range("D5").value = totalDict("ng")ws2.Range("D10").value = totalDict("posTotal")ws2.Range("D12").value = totalDict("posNG")ws2.Range("D11").value = totalDict("posTotal") - totalDict("posNG")ws2.Range("D7").value = totalDict("lab")ws2.Range("D8").value = totalDict("color")ws2.Range("D9").value = totalDict("reflect")ws2.Range("D14").value = totalDict("labPos")ws2.Range("D15").value = totalDict("colorPos")ws2.Range("D16").value = totalDict("reflectPos")ws2.Range("D19").value = totalDict1("total1")ws2.Range("D20").value = totalDict1("ok1")ws2.Range("D21").value = totalDict1("ng1")ws2.Range("D26").value = totalDict1("posTotal1")ws2.Range("D28").value = totalDict1("posNG1")ws2.Range("D27").value = totalDict1("posTotal1") - totalDict1("posNG1")ws2.Range("D23").value = totalDict1("lab1")ws2.Range("D24").value = totalDict1("color1")ws2.Range("D25").value = totalDict1("reflect1")ws2.Range("D30").value = totalDict1("labPos1")ws2.Range("D31").value = totalDict1("colorPos1")ws2.Range("D32").value = totalDict1("reflectPos1")ws2.Range("D35").value = totalDict2("total2")ws2.Range("D36").value = totalDict2("ok2")ws2.Range("D37").value = totalDict2("ng2")ws2.Range("D42").value = totalDict2("posTotal2")ws2.Range("D44").value = totalDict2("posNG2")ws2.Range("D43").value = totalDict2("posTotal2") - totalDict2("posNG2")ws2.Range("D39").value = totalDict2("lab2")ws2.Range("D40").value = totalDict2("color2")ws2.Range("D41").value = totalDict2("reflect2")ws2.Range("D46").value = totalDict2("labPos2")ws2.Range("D47").value = totalDict2("colorPos2")ws2.Range("D48").value = totalDict2("reflectPos2")' 计算总通过率SetRateFormat ws2, 4, 6, totalDict("ok"), totalDict("total") ' 总流通率SetRateFormat ws2, 4, 13, (totalDict("posTotal") - totalDict("posNG")), totalDict("posTotal") ' 总位置通过率SetRateFormat ws2, 4, 22, totalDict1("ok1"), totalDict1("total1") ' 总流通率SetRateFormat ws2, 4, 29, (totalDict1("posTotal1") - totalDict1("posNG1")), totalDict1("posTotal1") ' 总位置通过率SetRateFormat ws2, 4, 38, totalDict2("ok2"), totalDict2("total2") ' 总流通率SetRateFormat ws2, 4, 45, (totalDict2("posTotal2") - totalDict2("posNG2")), totalDict2("posTotal2") ' 总位置通过率' 恢复设置Application.Calculation = xlCalculationAutomaticApplication.ScreenUpdating = TrueApplication.EnableEvents = TrueMsgBox "数据处理完成!", vbInformation
End SubPrivate Sub SetRateFormat(ws As Worksheet, col As Long, row As Long, numerator As Long, denominator As Long)If denominator > 0 And numerator >= 0 ThenDim rate As Doublerate = numerator / denominatorws.Cells(row, col).value = ratews.Cells(row, col).NumberFormat = "0.00%"' 设置颜色Select Case rateCase Is < 0.8ws.Cells(row, col).Interior.Color = RGB(255, 0, 0)Case Is < 0.9ws.Cells(row, col).Interior.Color = RGB(255, 165, 0)Case Is < 0.98ws.Cells(row, col).Interior.Color = RGB(255, 255, 0)Case Elsews.Cells(row, col).Interior.Color = RGB(0, 255, 0)End SelectElsews.Cells(row, col).value = ""ws.Cells(row, col).Interior.ColorIndex = xlNoneEnd If
End Sub

2.整体通过率

Option Explicit
' 主入口
Sub RunCalculation()Application.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualOn Error GoTo ErrorHandlerDim wsRec As Worksheet, wsCap As Worksheet, wsRef As WorksheetSet wsRec = ThisWorkbook.Sheets("测试记录")Set wsCap = ThisWorkbook.Sheets("人员产能")Set wsRef = ThisWorkbook.Sheets("工艺&客户整理")' 初始化设置InitializeCalculation wsCap' 根据T1值选择处理模式Select Case Trim(wsCap.Range("T1").value)Case "所有"ProcessAllMode wsRec, wsCapCase "合计"ProcessSummaryMode wsRec, wsCapCase ElseProcessSpecificMode wsRec, wsCapEnd Select' 更新班组信息UpdateTeamInfo wsCap, wsRef' 应用格式ApplyFinalFormat wsCapMsgBox "产能统计已完成！", vbInformationExit SubErrorHandler:MsgBox "执行出错：" & Err.Description, vbCriticalApplication.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomatic
End Sub' 初始化计算环境
Sub InitializeCalculation(wsCap As Worksheet)Dim rngToClear As RangeSet rngToClear = wsCap.Range("A3:AI" & wsCap.Rows.count)' 取消所有合并单元格If rngToClear.MergeCells ThenrngToClear.UnMergeEnd If' 清除内容和格式rngToClear.ClearrngToClear.NumberFormat = "General"' 设置数字格式（计数为0时显示空）wsCap.Range("D3:AI" & wsCap.Rows.count).NumberFormat = "0;;"
End Sub' 处理"所有"模式
Sub ProcessAllMode(wsRec As Worksheet, wsCap As Worksheet)Dim testers As Collection, i As Long, j As LongSet testers = GetUniqueTesters(wsRec)' 填充测试员和工艺结构For i = 0 To testers.count - 1Dim startRow As LongstartRow = 3 + (i * 7)' 设置测试员合并单元格With wsCap.Range("B" & startRow & ":B" & startRow + 6).Merge.value = testers(i + 1).HorizontalAlignment = xlCenter.VerticalAlignment = xlCenterEnd With' 填充工艺类型wsCap.Cells(startRow, "C").value = "4"wsCap.Cells(startRow + 1, "C").value = "8"wsCap.Cells(startRow + 2, "C").value = "PVD"wsCap.Cells(startRow + 3, "C").value = "ALC"wsCap.Cells(startRow + 4, "C").value = "PVD+ALC"wsCap.Cells(startRow + 5, "C").value = "ALC+PVD"wsCap.Cells(startRow + 6, "C").value = "合计"' 计算各工艺数据For j = 0 To 6CalculateProcessData wsRec, wsCap, startRow + j, testers(i + 1), wsCap.Cells(startRow + j, "C").valueNext j' 计算组合计CalculateGroupTotal wsCap, startRowNext i
End Sub' 处理"合计"模式
Sub ProcessSummaryMode(wsRec As Worksheet, wsCap As Worksheet)Dim testers As Collection, i As LongSet testers = GetUniqueTesters(wsRec)' 填充测试员和工艺类型For i = 1 To testers.countwsCap.Cells(i + 2, "B").value = testers(i)wsCap.Cells(i + 2, "C").value = "合计"CalculateDailyCount wsRec, wsCap, i + 2, testers(i), "合计"Next i
End Sub' 处理特定工艺模式
Sub ProcessSpecificMode(wsRec As Worksheet, wsCap As Worksheet)Dim testers As Collection, i As Long, process As StringSet testers = GetUniqueTesters(wsRec)process = wsCap.Range("T1").value' 填充测试员和工艺类型For i = 1 To testers.countwsCap.Cells(i + 2, "B").value = testers(i)wsCap.Cells(i + 2, "C").value = processCalculateDailyCount wsRec, wsCap, i + 2, testers(i), processNext i
End Sub' 计算工艺数据
Sub CalculateProcessData(wsRec As Worksheet, wsCap As Worksheet, rowNum As Long, tester As String, process As String)Dim dateCell As Range, countVal As LongDim startDate As Date, endDate As DateDim colSum As LongstartDate = wsCap.Range("L1").valueendDate = wsCap.Range("P1").valuecolSum = 0' 计算每日数量For Each dateCell In GetDateRange(wsCap, startDate, endDate)If process = "合计" ThencountVal = Application.CountIfs(wsRec.Columns("A"), dateCell.value, _wsRec.Columns("C"), tester)ElsecountVal = Application.CountIfs(wsRec.Columns("A"), dateCell.value, _wsRec.Columns("C"), tester, _wsRec.Columns("V"), process)End IfIf countVal > 0 ThenwsCap.Cells(rowNum, dateCell.Column).value = countValcolSum = colSum + countValEnd IfNext dateCell' 输出D列合计If colSum > 0 Then wsCap.Cells(rowNum, "D").value = colSum
End Sub' 获取日期范围内的单元格
Function GetDateRange(wsCap As Worksheet, startDate As Date, endDate As Date) As CollectionDim dateCell As Range, col As New CollectionFor Each dateCell In wsCap.Range("E2:AI2").CellsIf IsDate(dateCell.value) ThenIf dateCell.value >= startDate And dateCell.value <= endDate Thencol.Add dateCellEnd IfEnd IfNext dateCellSet GetDateRange = col
End Function' 计算组合计行
Sub CalculateGroupTotal(wsCap As Worksheet, startRow As Long)Dim col As Long, sumVal As Long' 计算日期列合计（E到AI列）For col = 5 To 35sumVal = Application.Sum(wsCap.Range(wsCap.Cells(startRow, col), wsCap.Cells(startRow + 5, col)))wsCap.Cells(startRow + 6, col).value = sumValNext col' 计算D列合计sumVal = Application.Sum(wsCap.Range(wsCap.Cells(startRow, "D"), wsCap.Cells(startRow + 5, "D")))wsCap.Cells(startRow + 6, "D").value = sumVal
End Sub' 计算每日数量(简化版)
Sub CalculateDailyCount(wsRec As Worksheet, wsCap As Worksheet, rowNum As Long, tester As String, process As String)Dim dateCell As Range, countVal As LongDim startDate As Date, endDate As DateDim colSum As LongstartDate = wsCap.Range("L1").valueendDate = wsCap.Range("P1").valuecolSum = 0For Each dateCell In GetDateRange(wsCap, startDate, endDate)If process = "合计" ThencountVal = Application.CountIfs(wsRec.Columns("A"), dateCell.value, _wsRec.Columns("C"), tester)ElsecountVal = Application.CountIfs(wsRec.Columns("A"), dateCell.value, _wsRec.Columns("C"), tester, _wsRec.Columns("V"), process)End IfIf countVal > 0 ThenwsCap.Cells(rowNum, dateCell.Column).value = countValcolSum = colSum + countValEnd IfNext dateCell' 输出D列合计wsCap.Cells(rowNum, "D").value = colSum
End Sub' 更新班组信息
Sub UpdateTeamInfo(wsCap As Worksheet, wsRef As Worksheet)Dim lastRow As Long, i As LongDim tester As String, team As StringDim dict As ObjectSet dict = CreateObject("Scripting.Dictionary")lastRow = GetLastRow(wsRef, "G")' 建立测试员-班组映射For i = 3 To lastRowtester = Trim(wsRef.Cells(i, "G").value)team = Trim(wsRef.Cells(i, "F").value)If Len(tester) > 0 And Not dict.Exists(tester) Thendict.Add tester, teamEnd IfNext i' 更新班组信息lastRow = GetLastRow(wsCap, "B")For i = 3 To lastRowtester = Trim(wsCap.Cells(i, "B").value)If Len(tester) > 0 And dict.Exists(tester) ThenwsCap.Cells(i, "A").value = dict(tester)End IfNext i' "所有"模式下合并A列单元格If Trim(wsCap.Range("T1").value) = "所有" ThenFor i = 3 To lastRow Step 7' 避免重复合并已经合并的单元格If Not wsCap.Range("A" & i & ":A" & i + 6).MergeCells ThenWith wsCap.Range("A" & i & ":A" & i + 6).Merge.HorizontalAlignment = xlCenter.VerticalAlignment = xlCenterEnd WithEnd IfNext iEnd If
End Sub' 应用最终格式
Sub ApplyFinalFormat(wsCap As Worksheet)Dim lastRow As LonglastRow = GetLastRow(wsCap, "B")' 设置居中With wsCap.Range("A3:AI" & lastRow).HorizontalAlignment = xlCenter.VerticalAlignment = xlCenterEnd With' 设置边框With wsCap.Range("A3:AI" & lastRow).Borders.LineStyle = xlContinuous.weight = xlThinEnd With
End Sub' 获取唯一测试员列表
Function GetUniqueTesters(wsRec As Worksheet) As CollectionDim lastRow As Long, i As LongDim testers As New CollectionDim dict As ObjectSet dict = CreateObject("Scripting.Dictionary")lastRow = GetLastRow(wsRec, "C")For i = 3 To lastRowDim tester As Stringtester = Trim(wsRec.Cells(i, "C").value)If Len(tester) > 0 And Not dict.Exists(tester) Thendict.Add tester, 1testers.Add testerEnd IfNext iSet GetUniqueTesters = testers
End Function' 获取最后一行
Function GetLastRow(ws As Worksheet, col As String) As LongGetLastRow = ws.Cells(ws.Rows.count, col).End(xlUp).rowIf GetLastRow < 3 Then GetLastRow = 3 ' 确保最小行数为3
End Function

3.客户工艺匹配

Option Explicit
Sub FastDataMatcher()Dim ws1 As Worksheet, ws2 As WorksheetDim dict As Object, arrData(), arrRef(), arrResult()Dim lRow1 As Long, lRow2 As Long, i As LongDim sDate As Date, eDate As DateDim sKey As String, sMiss As StringDim tStart As Double' 初始化计时和性能设置tStart = TimerApplication.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualApplication.EnableEvents = False' 设置工作表对象Set ws1 = ThisWorkbook.Sheets("测试记录")Set ws2 = ThisWorkbook.Sheets("工艺&客户整理")sDate = ws1.Range("L1").valueeDate = ws1.Range("P1").value' 预加载参考数据到字典（从第3行开始）Set dict = CreateObject("Scripting.Dictionary")lRow2 = ws2.Cells(ws2.Rows.count, "A").End(xlUp).rowarrRef = ws2.Range("A3:D" & lRow2).valueFor i = 1 To UBound(arrRef)dict(arrRef(i, 1) & "|" & arrRef(i, 2)) = Array(arrRef(i, 3), arrRef(i, 4))Next' 加载目标数据到数组（从第3行开始）lRow1 = ws1.Cells(ws1.Rows.count, "A").End(xlUp).rowarrData = ws1.Range("A3:V" & lRow1).valueReDim arrResult(1 To UBound(arrData), 1 To 2)' 主处理循环（带日期范围筛选）For i = 1 To UBound(arrData)If arrData(i, 1) >= sDate And arrData(i, 1) <= eDate ThensKey = arrData(i, 7) & "|" & arrData(i, 8)If dict.Exists(sKey) ThenarrResult(i, 1) = dict(sKey)(0)  '终端arrResult(i, 2) = dict(sKey)(1)  '工艺ElsearrResult(i, 1) = "请维护该机种终端"arrResult(i, 2) = "请维护该机种工艺"sMiss = sMiss & vbCrLf & sKeyEnd IfEnd IfNext' 批量写入结果（从U3/V3开始）ws1.Range("U3:V" & lRow1).value = arrResult' 恢复设置Application.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomaticApplication.EnableEvents = True' 输出统计报告Dim msg As Stringmsg = "处理完成，耗时：" & Format(Timer - tStart, "0.00") & "秒"If sMiss <> "" Thenmsg = msg & vbCrLf & "以下机种&件号未匹配：" & sMissEnd IfMsgBox msg, vbInformation, "执行报告"
End Sub

4.机台通过率分析

vba 高速处理excel 10万行以上数据
sheet1名称为测试记录，第二行为标题行，A2列标题测试日期，B2列标题班次，C2列标题测试员，D2列标题测试仪，E2列标题机台，F2列标题罩次，G2列标题机种，H2列标题件号，K2列标题判定，L2列标题异常项目，N2列标题位置，U2列标题终端，V2列标题工艺
sheet2名称为机台分析，第二行为标题行，C2标题为机台，D2标题为合计，E2：AI2分别为6/1-7/1日期
sheet2 L1为起始日期，P1为终止日期 T1为选择类型
vba实现以下功能：
1）清除sheet2 C3:AI区域单元格内容
2）判断sheet2 T1的值，
若sheet2 T1内容等于镜筒，提取sheet1 A3列日期 等于sheet2 起始日期L1 至 终止日期P1所有日期 且sheet1 H3列件号小于800， sheet1 E3列的不重复值，按升序排列后，输出到sheet2 C3列，sheet2 C3列设置单元格居中
若sheet2 T1内容等于镜片，提取sheet1 A3列日期 等于sheet2 起始日期L1 至 终止日期P1所有日期 且sheet1 H3列件号大于800， sheet1 E3列的不重复值，按升序排列后，输出到sheet2 C3列，sheet2 C3列设置单元格居中
若sheet2 T1内容等于所有，提取sheet1 A3列日期 等于sheet2 起始日期L1 至 终止日期P1所有日期 ， sheet1 E3列的不重复值，按升序排列后，输出到sheet2 C3列，sheet2 C3设置单元格居中
计数a=(sheet1 E3列 等于sheet2 C3列 且sheet1 A3列日期 等于sheet2 L1起始日期至 P1终止日期且等于sheet2 E2:AI2指定日期)
计数b=(sheet1 E3列 等于sheet2 C3列 且sheet1 A3列日期 等于sheet2 L1起始日期至 P1终止日期且等于sheet2 E2：AI2指定日期且sheet1 K3列为“OK" )
计算c=b/a，设置c格式，百分比保留2位小数，输出到sheet2 C列机台对应行，E2:AI2日期对应列，计算错误或空值不填充颜色，c值小于80%标红,c值80%-90%标橙色，c值90%-98%标黄，c值98%以上标绿
计数d=(sheet1 E3列 等于sheet2 C3列 且sheet1 A3列日期 等于sheet2 L1起始日期至 P1终止日期且等于sheet2 E2:AI2所有日期)
计数e=(sheet1 E3列 等于sheet2 C3列 且sheet1 A3列日期 等于sheet2 L1起始日期至 P1终止日期且等于sheet2 E2：AI2所有日期且sheet1 K3列为“OK" )
计算f=e/d，设置f格式，百分比保留2位小数，输出到sheet2 C列机台对应的行 D列，计算错误或空值不填充颜色，f值小于80%标红,f值80%-90%标橙色，f值90%-98%标黄，f值98%以上标绿

Option Explicit
Sub ProcessMachineData()Dim ws1 As Worksheet, ws2 As WorksheetDim machineDict As Object, dateDict As ObjectDim dataArr As Variant, machineList() As StringDim startDate As Date, endDate As DateDim lastRow As Long, i As Long, j As Long, k As Long' 性能优化设置Application.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualApplication.EnableEvents = False' 初始化工作表Set ws1 = ThisWorkbook.Sheets("测试记录")Set ws2 = ThisWorkbook.Sheets("机台分析")Set machineDict = CreateObject("Scripting.Dictionary")Set dateDict = CreateObject("Scripting.Dictionary")' 1. 清除目标区域ws2.Range("C3:AI" & ws2.Rows.count).ClearContentsws2.Range("C3:AI" & ws2.Rows.count).Interior.ColorIndex = xlNone' 获取日期范围startDate = ws2.Range("L1").valueendDate = ws2.Range("P1").value' 2. 加载数据到数组lastRow = ws1.Cells(ws1.Rows.count, "A").End(xlUp).rowIf lastRow < 3 Then Exit SubdataArr = ws1.Range("A3:V" & lastRow).value' 3. 根据条件筛选机台Dim filterType As StringfilterType = Trim(ws2.Range("T1").value)For i = LBound(dataArr) To UBound(dataArr)If IsDate(dataArr(i, 1)) ThenDim currentDate As Date: currentDate = dataArr(i, 1)If currentDate >= startDate And currentDate <= endDate ThenDim partNo As Long: partNo = Val(dataArr(i, 8))Dim machineName As String: machineName = Trim(dataArr(i, 5))If Len(machineName) > 0 ThenSelect Case filterTypeCase "镜筒": If partNo < 800 Then machineDict(machineName) = 1Case "镜片": If partNo > 800 Then machineDict(machineName) = 1Case Else: machineDict(machineName) = 1End SelectEnd IfEnd IfEnd IfNext i' 4. 输出机台列表（修复显示问题）ReDim machineList(0 To machineDict.count - 1)k = 0Dim machine As VariantFor Each machine In machineDict.keysmachineList(k) = CStr(machine)k = k + 1NextIf UBound(machineList) >= 0 ThenQuickSort machineList, LBound(machineList), UBound(machineList)For i = 0 To UBound(machineList)With ws2.Cells(3 + i, 3).value = machineList(i).HorizontalAlignment = xlCenterEnd WithNext iEnd If' 5. 预构建日期字典For j = 5 To 35If IsDate(ws2.Cells(2, j).value) ThendateDict.Add j, ws2.Cells(2, j).valueEnd IfNext j' 6. 主统计逻辑For i = 0 To UBound(machineList)machineName = machineList(i)' 合计统计Dim totalAll As Long: totalAll = 0Dim passedAll As Long: passedAll = 0' 每日统计Dim dateCol As VariantFor Each dateCol In dateDict.keysDim targetDate As Date: targetDate = dateDict(dateCol)Dim totalDaily As Long: totalDaily = 0Dim passedDaily As Long: passedDaily = 0For j = LBound(dataArr) To UBound(dataArr)If Trim(dataArr(j, 5)) = machineName And _IsDate(dataArr(j, 1)) And _dataArr(j, 1) = targetDate ThentotalAll = totalAll + 1totalDaily = totalDaily + 1If UCase(Trim(dataArr(j, 11))) = "OK" ThenpassedAll = passedAll + 1passedDaily = passedDaily + 1End IfEnd IfNext j' 写入每日通过率If totalDaily > 0 ThenDim dailyRate As DoubledailyRate = passedDaily / totalDailyWith ws2.Cells(3 + i, dateCol).value = dailyRate.NumberFormat = "0.00%"ApplyColorFormat .Cells(1, 1), dailyRateEnd WithEnd IfNext dateCol' 写入合计通过率If totalAll > 0 ThenDim totalRate As DoubletotalRate = passedAll / totalAllWith ws2.Cells(3 + i, 4).value = totalRate.NumberFormat = "0.00%"ApplyColorFormat .Cells(1, 1), totalRateEnd WithEnd IfNext i' 恢复设置Application.Calculation = xlCalculationAutomaticApplication.ScreenUpdating = TrueApplication.EnableEvents = TrueMsgBox "处理完成！共分析 " & machineDict.count & " 台设备", vbInformation
End SubPrivate Sub QuickSort(arr() As String, first As Long, last As Long)Dim pivot As String, temp As StringDim i As Long, j As LongIf first < last Thenpivot = arr((first + last) \ 2)i = firstj = lastDoDo While StrComp(arr(i), pivot, vbTextCompare) < 0: i = i + 1: LoopDo While StrComp(arr(j), pivot, vbTextCompare) > 0: j = j - 1: LoopIf i <= j Thentemp = arr(i): arr(i) = arr(j): arr(j) = tempi = i + 1: j = j - 1End IfLoop Until i > jIf first < j Then QuickSort arr, first, jIf i < last Then QuickSort arr, i, lastEnd If
End SubPrivate Sub ApplyColorFormat(cell As Range, rate As Double)If rate < 0.8 Thencell.Interior.Color = RGB(255, 0, 0)ElseIf rate < 0.9 Thencell.Interior.Color = RGB(255, 165, 0)ElseIf rate < 0.98 Thencell.Interior.Color = RGB(255, 255, 0)ElseIf rate >= 0.98 Thencell.Interior.Color = RGB(0, 255, 0)End If
End Sub

5.镜片通过率罩次分析

分析1.1

vba 高速处理excel 10万行以上数据
sheet1名称为测试记录，第二行为标题行，A2列标题测试日期，B2列标题班次，C2列标题测试员，D2列标题测试仪，E2列标题机台，F2列标题罩次，G2列标题机种，H2列标题件号，K2列标题判定，L2列标题异常项目，N2列标题位置，U2列标题终端，V2列标题工艺
sheet2名称为镜片通过率罩次分析，第二行为标题行，A2列标题终端，B2列标题机种，C2列标题件号，D2列标题合计，E2：AI2分别为6/1-7/1日期，AJ2列标题LAB异常，AK2列标题膜色异常，AL2列标题反射率异常，AM2列标题上，AN2列标题中，AO2列标题下，AP2列标题整罩 ，L1单元格为起始日期，P1单元格为终止日期
sheet3名称为工艺&客户整理，第二行为标题行，A2列标题机种，B2列标题件号，C2列标题终端，D2列标题工艺
vba实现以下功能：
1）清除sheet2 A3:AP区域单元格内容以及单元格格式
2）提取sheet1 A3列日期 等于sheet2 起始日期L1 至 终止日期P1所有日期 且sheet1 G3列机种&H3列件号(H3列内容小于800)的不重复值，不重复值按机种和件号升序排列后，输出到sheet2 B3列&C3列，sheet2 B3&C3设置单元格居中
3）匹配sheet2 B3列机种&C3列件号等于sheet3 A3列机种&B3列件号时，sheet3 C3列内容到sheet2 A3列，按sheet2 A3列升序排列，sheet2,A3列设置单元格居中
4）计数a=(sheet1 G3列&H3列 等于sheet2 B3列&C3列 且sheet1 A3列日期 等于sheet2 L1起始日期至 P1终止日期所有日期 且sheet1 K3列为“OK”)
计数b=(sheet1 G3列&H3列 等于sheet2 B3列&C3列 且sheet1 A3列日期 等于sheet2 L1起始日期至 P1终止日期所有日期 )
计算c=a/b，设置c格式，百分比保留2位小数，输出到sheet2 D3列，计算错误或空值不填充颜色，c值小于80%标红,c值80%-90%标橙色，c值90%-98%标黄，c值98%以上标绿
5）计数d=(sheet1 G3列&H3列 等于sheet2 B3列&C3列 且sheet1 A3列日期 分别等于sheet2 L1起始日期至 P1终止日期且等于sheet2 E2:AI2 对应日期 且sheet1 K3列为“OK”)
计数e=(sheet1 G3列&H3列 等于sheet2 B3列&C3列 且sheet1 A3列日期 分别等于sheet2 L1起始日期至 P1终止日期且等于sheet2 E2:AI2 对应日期 )
计算f=d/e，设置d格式，百分比保留2位小数，输出到E2：AI2日期等于L1至P1每个日期对应的列，计算错误或空值不填充颜色，f值小于80%标红,f值80%-90%标橙色，f值90%-98%标黄，f值98%以上标绿
修改源码计算错误或空值不填充颜色
6）计数：sheet1 G3列&H3列 等于sheet2 B3列&C3列 且sheet1 A3列日期 等于sheet2 L1起始日期至 P1终止日期所有日期 且sheet1 K3列为“NG”且sheet1 L3列内容包含“LAB”)输出到sheet2 AJ列，设置格式居中
计数：sheet1 G3列&H3列 等于sheet2 B3列&C3列 且sheet1 A3列日期 等于sheet2 L1起始日期至 P1终止日期所有日期 且sheet1 K3列为“NG”且sheet1 L3列内容包含“膜色”)输出到sheet2 AK3列，设置格式居中
计数：sheet1 G3列&H3列 等于sheet2 B3列&C3列 且sheet1 A3列日期 等于sheet2 L1起始日期至 P1终止日期所有日期 且sheet1 K3列为“NG”且sheet1 L3列内容包含“反射率”)输出到sheet2 AL3列，设置格式居中
7）
计数：(sheet1 G3列&H3列 等于sheet2 B3列&C3列 且sheet1 A3列日期 等于sheet2 L1起始日期至 P1终止日期的所有日期 且sheet1 K3列为“NG”且sheet1 N3列内容中“上”的个数)等于g
计数：(sheet1 G3列&H3列 等于sheet2 B3列&C3列 且sheet1 A3列日期 等于sheet2 L1起始日期至 P1终止日期的所有日期 且sheet1 K3列为“NG”且sheet1 N3列内容“上”个数+“中”个数+“下”个数+“整罩”个数) 等于h
计算 g/h 百分比保留2位小数 输出到sheet2 AM3列，设置格式居中
计数：(sheet1 G3列&H3列 等于sheet2 B3列&C3列 且sheet1 A3列日期 等于sheet2 L1起始日期至 P1终止日期的所有日期 且sheet1 K3列为“NG”且sheet1 N3列内容中“中”的个数)等于k
计数：(sheet1 G3列&H3列 等于sheet2 B3列&C3列 且sheet1 A3列日期 等于sheet2 L1起始日期至 P1终止日期的所有日期 且sheet1 K3列为“NG”且sheet1 N3列内容“上”个数+“中”个数+“下”个数+“整罩”个数) 等于l
计算 k/l 百分比保留2位小数 输出到sheet2 AN3列，设置格式居中
计数：(sheet1 G3列&H3列 等于sheet2 B3列&C3列 且sheet1 A3列日期 等于sheet2 L1起始日期至 P1终止日期的所有日期 且sheet1 K3列为“NG”且sheet1 N3列内容中“下”的个数)等于m
计数：(sheet1 G3列&H3列 等于sheet2 B3列&C3列 且sheet1 A3列日期 等于sheet2 L1起始日期至 P1终止日期的所有日期 且sheet1 K3列为“NG”且sheet1 N3列内容“上”个数+“中”个数+“下”个数+“整罩”个数) 等于n
计算 m/n 百分比保留2位小数 输出到sheet2 AO3列，设置格式居中
计数：(sheet1 G3列&H3列 等于sheet2 B3列&C3列 且sheet1 A3列日期 等于sheet2 L1起始日期至 P1终止日期的所有日期 且sheet1 K3列为“NG”且sheet1 N3列内容中“整罩”的个数)等于o
计数：(sheet1 G3列&H3列 等于sheet2 B3列&C3列 且sheet1 A3列日期 等于sheet2 L1起始日期至 P1终止日期的所有日期 且sheet1 K3列为“NG”且sheet1 N3列内容“上”个数+“中”个数+“下”个数+“整罩”个数) 等于p
计算 o/p 百分比保留2位小数 输出到sheet2 AP3列，设置格式居中

Option Explicit
Sub ProcessMassiveData()' 性能优化设置Application.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualApplication.EnableEvents = FalseDim ws1 As Worksheet, ws2 As Worksheet, ws3 As WorksheetSet ws1 = Sheets("测试记录")Set ws2 = Sheets("镜片通过率罩次分析")Set ws3 = Sheets("工艺&客户整理")' 功能1：清除Sheet2数据区域With ws2.Range("A3:AP" & ws2.Rows.count).ClearContents.ClearFormatsEnd With' 获取日期范围Dim startDate As Date, endDate As DatestartDate = ws2.Range("L1").valueendDate = ws2.Range("P1").value' 功能2：提取并处理数据Dim dict As Object, arrData(), arrResult()   '声明一个名为dict的变量，类型为Object对象类型Set dict = CreateObject("Scripting.Dictionary") '绑定创建字典对象Dim lastRow As Long   'long 类型可存储-2147483648 到 2147483647lastRow = ws1.Cells(ws1.Rows.count, "A").End(xlUp).row' 将数据读入数组提升性能arrData = ws1.Range("A3:V" & lastRow).value' 筛选处理（日期范围+件号>800）Dim i As Long, comboKey As StringFor i = LBound(arrData) To UBound(arrData)  'LBound是用于获取数组下限最小索引的函数If IsDate(arrData(i, 1)) ThenIf arrData(i, 1) >= startDate And arrData(i, 1) <= endDate ThenIf Val(arrData(i, 8)) > 800 Then ' H列件号>800comboKey = arrData(i, 7) & "|" & arrData(i, 8) ' G|H列组合键If Not dict.Exists(comboKey) Thendict.Add comboKey, Array(arrData(i, 7), arrData(i, 8))End IfEnd IfEnd IfEnd IfNext i' 排序输出ReDim arrResult(1 To dict.count, 1 To 2) '动态调整数组大小的语句，重新定义二维数组arrResult的维度'第一维大小设置为字典对象dict的元素数量1到dict.count，第二维固定为2列（1到2）'将字典数据转换为二维数组结构，准备输出到工作表的数据容器，动态构建结果集数组'会清除数组原有数据，只能调整最后一维的大小，此处第二维固定，dict.count必须大于0Dim keys() As Variantkeys = dict.keysQuickSort keys, LBound(keys), UBound(keys)'将字典对象的键提取到Variant数组，使用QuickSort排序，排序范围为LBound(keys), UBound(keys)' 填充结果数组Dim counter As Longcounter = 0For i = LBound(keys) To UBound(keys)counter = counter + 1arrResult(counter, 1) = dict(keys(i))(0) ' 机种arrResult(counter, 2) = dict(keys(i))(1) ' 件号Next i' 批量写入结果到Sheet2With ws2.Range("B3:C" & 2 + dict.count).value = arrResult.HorizontalAlignment = xlCenter.VerticalAlignment = xlCenterEnd With' 功能3：跨表匹配终端信息并排序Dim arrMatch(), lastMatchRow As LonglastMatchRow = ws3.Cells(ws3.Rows.count, "A").End(xlUp).rowIf lastMatchRow >= 3 ThenarrMatch = ws3.Range("A3:D" & lastMatchRow).value' 构建匹配字典Dim matchDict As ObjectSet matchDict = CreateObject("Scripting.Dictionary")For i = LBound(arrMatch) To UBound(arrMatch)matchDict(arrMatch(i, 1) & "|" & arrMatch(i, 2)) = arrMatch(i, 3)Next i' 执行匹配Dim outputArr(), matchKey As StringReDim outputArr(1 To dict.count, 1 To 1)For i = 1 To dict.countmatchKey = arrResult(i, 1) & "|" & arrResult(i, 2)outputArr(i, 1) = IIf(matchDict.Exists(matchKey), matchDict(matchKey), "")Next i' 写入终端数据With ws2.Range("A3:A" & 2 + dict.count).value = outputArr.HorizontalAlignment = xlCenterEnd With' 按A列终端排序With ws2.Range("A3:C" & 2 + dict.count).Sort Key1:=ws2.Range("A3"), Order1:=xlDescending, Header:=xlNo  'xlDescending  xlAscendingEnd WithEnd If' 获取日期列标题Dim dateHeaders() As VariantdateHeaders = ws2.Range("E2:AI2").value' 构建日期列索引字典Dim dateColDict As ObjectSet dateColDict = CreateObject("Scripting.Dictionary")For i = LBound(dateHeaders, 2) To UBound(dateHeaders, 2)If IsDate(dateHeaders(1, i)) ThenIf dateHeaders(1, i) >= startDate And dateHeaders(1, i) <= endDate ThendateColDict(CLng(dateHeaders(1, i))) = i + 4 ' E列是第5列End IfEnd IfNext i' 构建机种件号字典用于快速查找Dim itemDict As ObjectSet itemDict = CreateObject("Scripting.Dictionary")For i = 1 To dict.countitemDict(ws2.Cells(i + 2, 2).value & "|" & ws2.Cells(i + 2, 3).value) = iNext i' 初始化统计数组Dim arrCalc(), calcRow As Long, j As Long'Debug.Print dict.count,ReDim arrCalc(1 To dict.count, 1 To 36) ' 0:总通过率 1-4:位置统计 5-20:日期列统计21' 初始化异常统计数组Dim ngStats() As LongReDim ngStats(1 To dict.count, 1 To 4) ' 上中下整罩计数Dim labStats() As Long, colorStats() As Long, reflectStats() As LongReDim labStats(1 To dict.count)ReDim colorStats(1 To dict.count)ReDim reflectStats(1 To dict.count)For i = 1 To dict.countarrCalc(i, 1) = Array(0, 0) ' 总通过率(OK数,总数)For j = 2 To 5arrCalc(i, j) = Array(0, 0) ' 位置统计(特定位置数,总NG数)Next jFor j = 6 To 36 '21arrCalc(i, j) = Array(0, 0) ' 日期列统计(OK数,总数)Next jNext i' 计算统计数据Dim itemIndex As Long, posText As String, currentDate As LongFor calcRow = LBound(arrData) To UBound(arrData)If IsDate(arrData(calcRow, 1)) ThencurrentDate = CLng(arrData(calcRow, 1))If currentDate >= CLng(startDate) And currentDate <= CLng(endDate) ThencomboKey = arrData(calcRow, 7) & "|" & arrData(calcRow, 8)If itemDict.Exists(comboKey) ThenitemIndex = itemDict(comboKey)' 总统计arrCalc(itemIndex, 1)(1) = arrCalc(itemIndex, 1)(1) + 1 ' 总数+1If UCase(arrData(calcRow, 11)) = "OK" ThenarrCalc(itemIndex, 1)(0) = arrCalc(itemIndex, 1)(0) + 1 ' OK数+1End If' 日期列统计If dateColDict.Exists(currentDate) ThenDim colIndex As LongcolIndex = dateColDict(currentDate) - 4 ' 转换为dateHeaders索引If colIndex >= LBound(dateHeaders, 2) And colIndex <= UBound(dateHeaders, 2) Then'Debug.Print LBound(dateHeaders, 2), itemIndex, 6 + colIndexarrCalc(itemIndex, 6 + colIndex)(1) = arrCalc(itemIndex, 6 + colIndex)(1) + 1'arrCalc是数组变量名，（itemIndex,6+colIndex）表示访问二维数组的指定行列，外层的1表示第一个索引值'Debug.Print arrCalc(itemIndex, 6 + colIndex)(1)If UCase(arrData(calcRow, 11)) = "OK" ThenarrCalc(itemIndex, 6 + colIndex)(0) = arrCalc(itemIndex, 6 + colIndex)(0) + 1End IfEnd IfEnd If' NG统计If UCase(arrData(calcRow, 11)) = "NG" Then' 异常项目统计If InStr(arrData(calcRow, 12), "LAB") > 0 Then labStats(itemIndex) = labStats(itemIndex) + 1If InStr(arrData(calcRow, 12), "膜色") > 0 Then colorStats(itemIndex) = colorStats(itemIndex) + 1If InStr(arrData(calcRow, 12), "反射率") > 0 Then reflectStats(itemIndex) = reflectStats(itemIndex) + 1' 位置统计posText = arrData(calcRow, 14)If InStr(posText, "上") > 0 Then ngStats(itemIndex, 1) = ngStats(itemIndex, 1) + 1If InStr(posText, "中") > 0 Then ngStats(itemIndex, 2) = ngStats(itemIndex, 2) + 1If InStr(posText, "下") > 0 Then ngStats(itemIndex, 3) = ngStats(itemIndex, 3) + 1If InStr(posText, "整罩") > 0 Then ngStats(itemIndex, 4) = ngStats(itemIndex, 4) + 1End IfEnd IfEnd IfEnd IfNext calcRow' 写入统计结果For i = 1 To dict.count' 功能4：合计通过率If arrCalc(i, 1)(1) > 0 Thenws2.Cells(i + 2, 4).value = arrCalc(i, 1)(0) / arrCalc(i, 1)(1)ws2.Cells(i + 2, 4).NumberFormat = "0.00%"End If' 功能5：每日通过率For j = LBound(dateHeaders, 2) To UBound(dateHeaders, 2)If dateColDict.Exists(CLng(dateHeaders(1, j))) ThencolIndex = dateColDict(CLng(dateHeaders(1, j)))If colIndex >= 5 And colIndex <= 35 Then ' E列到AI列If arrCalc(i, 6 + j)(1) > 0 Thenws2.Cells(i + 2, colIndex).value = arrCalc(i, 6 + j)(0) / arrCalc(i, 6 + j)(1)ws2.Cells(i + 2, colIndex).NumberFormat = "0.00%"End IfEnd IfEnd IfNext j' 功能6：异常项目统计ws2.Cells(i + 2, 36).value = labStats(i) ' AJ列ws2.Cells(i + 2, 37).value = colorStats(i) ' AK列ws2.Cells(i + 2, 38).value = reflectStats(i) ' AL列ws2.Range("AJ" & i + 2 & ":AL" & i + 2).HorizontalAlignment = xlCenter' 功能7：位置分布统计Dim totalPos As LongtotalPos = ngStats(i, 1) + ngStats(i, 2) + ngStats(i, 3) + ngStats(i, 4)If totalPos > 0 Then' 上ws2.Cells(i + 2, 39).value = ngStats(i, 1) / totalPos ' AM列' 中ws2.Cells(i + 2, 40).value = ngStats(i, 2) / totalPos ' AN列' 下ws2.Cells(i + 2, 41).value = ngStats(i, 3) / totalPos ' AO列' 整罩ws2.Cells(i + 2, 42).value = ngStats(i, 4) / totalPos ' AP列ws2.Range("AM" & i + 2 & ":AP" & i + 2).NumberFormat = "0.00%"ws2.Range("AM" & i + 2 & ":AP" & i + 2).HorizontalAlignment = xlCenterEnd IfNext i' 设置条件格式SetConditionalFormatting ws2.Range("D3:D" & 2 + dict.count)For j = 5 To 35 ' E列到AI列If j <= ws2.Columns.count ThenSetConditionalFormatting ws2.Range(ws2.Cells(3, j), ws2.Cells(2 + dict.count, j))End IfNext j' 恢复设置Application.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomaticApplication.EnableEvents = TrueMsgBox "处理完成！共处理 " & dict.count & " 条记录", vbInformation
End SubPrivate Sub SetConditionalFormatting(rng As Range)With rng.FormatConditions.Delete' 小于80%标红.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(ISNUMBER(" & rng.Cells(1, 1).Address(False, False) & ")," & rng.Cells(1, 1).Address(False, False) & "<0.8)".FormatConditions(1).Interior.Color = RGB(255, 0, 0)' 80%-90%标橙.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(ISNUMBER(" & rng.Cells(1, 1).Address(False, False) & ")," & rng.Cells(1, 1).Address(False, False) & ">=0.8," & rng.Cells(1, 1).Address(False, False) & "<0.9)".FormatConditions(2).Interior.Color = RGB(255, 165, 0)' 90%-98%标黄.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(ISNUMBER(" & rng.Cells(1, 1).Address(False, False) & ")," & rng.Cells(1, 1).Address(False, False) & ">=0.9," & rng.Cells(1, 1).Address(False, False) & "<0.98)".FormatConditions(3).Interior.Color = RGB(255, 255, 0)' 大于98%标绿.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(ISNUMBER(" & rng.Cells(1, 1).Address(False, False) & ")," & rng.Cells(1, 1).Address(False, False) & ">=0.98)".FormatConditions(4).Interior.Color = RGB(0, 255, 0)End With
End SubPrivate Sub QuickSort(arr() As Variant, ByVal first As Long, ByVal last As Long)Dim pivot As String, temp As VariantDim i As Long, j As LongIf first < last Thenpivot = arr((first + last) \ 2)i = firstj = lastDoDo While arr(i) < pivoti = i + 1LoopDo While arr(j) > pivotj = j - 1LoopIf i <= j Thentemp = arr(i)arr(i) = arr(j)arr(j) = tempi = i + 1j = j - 1End IfLoop Until i > jIf first < j Then QuickSort arr, first, jIf i < last Then QuickSort arr, i, lastEnd If
End Sub

分析1.2

Option Explicit
Sub ProcessMassiveData()' 性能优化设置Application.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualApplication.EnableEvents = FalseDim ws1 As Worksheet, ws2 As Worksheet, ws3 As WorksheetSet ws1 = Sheets("测试记录")Set ws2 = Sheets("镜片通过率罩次分析")Set ws3 = Sheets("工艺&客户整理")' 功能1：清除Sheet2数据区域With ws2.Range("A3:AP" & ws2.Rows.Count).ClearContents.ClearFormatsEnd With' 获取日期范围Dim startDate As Date, endDate As DatestartDate = ws2.Range("L1").valueendDate = ws2.Range("P1").value' 功能2：提取并处理数据Dim dict As Object, arrData(), arrResult()   '声明一个名为dict的变量，类型为Object对象类型Set dict = CreateObject("Scripting.Dictionary") '绑定创建字典对象Dim lastRow As Long   'long 类型可存储-2147483648 到 2147483647lastRow = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).row' 将数据读入数组提升性能arrData = ws1.Range("A3:V" & lastRow).value' 筛选处理（日期范围+件号>800）Dim i As Long, comboKey As StringFor i = LBound(arrData) To UBound(arrData)  'LBound是用于获取数组下限最小索引的函数If IsDate(arrData(i, 1)) ThenIf arrData(i, 1) >= startDate And arrData(i, 1) <= endDate ThenIf Val(arrData(i, 8)) > 800 Then ' H列件号>800comboKey = arrData(i, 7) & "|" & arrData(i, 8) ' G|H列组合键If Not dict.Exists(comboKey) Thendict.Add comboKey, Array(arrData(i, 7), arrData(i, 8))End IfEnd IfEnd IfEnd IfNext i' 排序输出ReDim arrResult(1 To dict.Count, 1 To 2) '动态调整数组大小的语句，重新定义二维数组arrResult的维度'第一维大小设置为字典对象dict的元素数量1到dict.count，第二维固定为2列（1到2）'将字典数据转换为二维数组结构，准备输出到工作表的数据容器，动态构建结果集数组'会清除数组原有数据，只能调整最后一维的大小，此处第二维固定，dict.count必须大于0Dim keys() As Variantkeys = dict.keysQuickSort keys, LBound(keys), UBound(keys)'将字典对象的键提取到Variant数组，使用QuickSort排序，排序范围为LBound(keys), UBound(keys)' 填充结果数组Dim counter As Longcounter = 0For i = LBound(keys) To UBound(keys)counter = counter + 1arrResult(counter, 1) = dict(keys(i))(0) ' 机种arrResult(counter, 2) = dict(keys(i))(1) ' 件号Next i' 批量写入结果到Sheet2With ws2.Range("B3:C" & 2 + dict.Count).value = arrResult.HorizontalAlignment = xlCenter.VerticalAlignment = xlCenterEnd With' 功能3：跨表匹配终端信息并排序Dim arrMatch(), lastMatchRow As LonglastMatchRow = ws3.Cells(ws3.Rows.Count, "A").End(xlUp).rowIf lastMatchRow >= 3 ThenarrMatch = ws3.Range("A3:D" & lastMatchRow).value' 构建匹配字典Dim matchDict As ObjectSet matchDict = CreateObject("Scripting.Dictionary")For i = LBound(arrMatch) To UBound(arrMatch)matchDict(arrMatch(i, 1) & "|" & arrMatch(i, 2)) = arrMatch(i, 3)Next i' 执行匹配Dim outputArr(), matchKey As StringReDim outputArr(1 To dict.Count, 1 To 1)For i = 1 To dict.CountmatchKey = arrResult(i, 1) & "|" & arrResult(i, 2)outputArr(i, 1) = IIf(matchDict.Exists(matchKey), matchDict(matchKey), "")Next i' 写入终端数据With ws2.Range("A3:A" & 2 + dict.Count).value = outputArr.HorizontalAlignment = xlCenterEnd With' 按A列终端排序With ws2.Range("A3:C" & 2 + dict.Count).Sort Key1:=ws2.Range("A3"), Order1:=xlDescending, Header:=xlNo  'xlDescending  xlAscendingEnd WithEnd If' 获取日期列标题Dim dateHeaders() As VariantdateHeaders = ws2.Range("E2:AI2").value' 构建日期列索引字典Dim dateColDict As ObjectSet dateColDict = CreateObject("Scripting.Dictionary")For i = LBound(dateHeaders, 2) To UBound(dateHeaders, 2)If IsDate(dateHeaders(1, i)) ThenIf dateHeaders(1, i) >= startDate And dateHeaders(1, i) <= endDate ThendateColDict(CLng(dateHeaders(1, i))) = i + 4 ' E列是第5列End IfEnd IfNext i' 构建机种件号字典用于快速查找Dim itemDict As ObjectSet itemDict = CreateObject("Scripting.Dictionary")For i = 1 To dict.CountitemDict(ws2.Cells(i + 2, 2).value & "|" & ws2.Cells(i + 2, 3).value) = iNext i' 初始化统计数组Dim arrCalc(), calcRow As Long, j As Long'Debug.Print dict.count,ReDim arrCalc(1 To dict.Count, 1 To 37) ' 0:总通过率 1-4:位置统计 5-20:日期列统计21' 初始化异常统计数组Dim ngStats() As LongReDim ngStats(1 To dict.Count, 1 To 4) ' 上中下整罩计数Dim labStats() As Long, colorStats() As Long, reflectStats() As LongReDim labStats(1 To dict.Count)ReDim colorStats(1 To dict.Count)ReDim reflectStats(1 To dict.Count)For i = 1 To dict.CountarrCalc(i, 1) = Array(0, 0) ' 总通过率(OK数,总数)For j = 2 To 5arrCalc(i, j) = Array(0, 0) ' 位置统计(特定位置数,总NG数)Next jFor j = 6 To 37 '21arrCalc(i, j) = Array(0, 0) ' 日期列统计(OK数,总数)Next jNext i' 计算统计数据Dim itemIndex As Long, posText As String, currentDate As LongFor calcRow = LBound(arrData) To UBound(arrData)If IsDate(arrData(calcRow, 1)) ThencurrentDate = CLng(arrData(calcRow, 1))If currentDate >= CLng(startDate) And currentDate <= CLng(endDate) ThencomboKey = arrData(calcRow, 7) & "|" & arrData(calcRow, 8)If itemDict.Exists(comboKey) ThenitemIndex = itemDict(comboKey)' 总统计arrCalc(itemIndex, 1)(1) = arrCalc(itemIndex, 1)(1) + 1 ' 总数+1If UCase(arrData(calcRow, 11)) = "OK" ThenarrCalc(itemIndex, 1)(0) = arrCalc(itemIndex, 1)(0) + 1 ' OK数+1End If' 日期列统计If dateColDict.Exists(currentDate) ThenDim colIndex As LongcolIndex = dateColDict(currentDate) - 4 ' 转换为dateHeaders索引If colIndex >= LBound(dateHeaders, 2) And colIndex <= UBound(dateHeaders, 2) Then'Debug.Print LBound(dateHeaders, 2), itemIndex, 6 + colIndexarrCalc(itemIndex, 6 + colIndex)(1) = arrCalc(itemIndex, 6 + colIndex)(1) + 1'arrCalc是数组变量名，（itemIndex,6+colIndex）表示访问二维数组的指定行列，外层的1表示第一个索引值'Debug.Print arrCalc(itemIndex, 6 + colIndex)(1)If UCase(arrData(calcRow, 11)) = "OK" ThenarrCalc(itemIndex, 6 + colIndex)(0) = arrCalc(itemIndex, 6 + colIndex)(0) + 1End IfEnd IfEnd If' NG统计If UCase(arrData(calcRow, 11)) = "NG" Then' 异常项目统计If InStr(arrData(calcRow, 12), "LAB") > 0 Then labStats(itemIndex) = labStats(itemIndex) + 1If InStr(arrData(calcRow, 12), "膜色") > 0 Then colorStats(itemIndex) = colorStats(itemIndex) + 1If InStr(arrData(calcRow, 12), "反射率") > 0 Then reflectStats(itemIndex) = reflectStats(itemIndex) + 1' 位置统计posText = arrData(calcRow, 14)If InStr(posText, "上") > 0 Then ngStats(itemIndex, 1) = ngStats(itemIndex, 1) + 1If InStr(posText, "中") > 0 Then ngStats(itemIndex, 2) = ngStats(itemIndex, 2) + 1If InStr(posText, "下") > 0 Then ngStats(itemIndex, 3) = ngStats(itemIndex, 3) + 1If InStr(posText, "整罩") > 0 Then ngStats(itemIndex, 4) = ngStats(itemIndex, 4) + 1End IfEnd IfEnd IfEnd IfNext calcRow' 写入统计结果For i = 1 To dict.Count' 功能4：合计通过率If arrCalc(i, 1)(1) > 0 Thenws2.Cells(i + 2, 4).value = arrCalc(i, 1)(0) / arrCalc(i, 1)(1)ws2.Cells(i + 2, 4).NumberFormat = "0.00%"End If' 功能5：每日通过率For j = LBound(dateHeaders, 2) To UBound(dateHeaders, 2)If dateColDict.Exists(CLng(dateHeaders(1, j))) ThencolIndex = dateColDict(CLng(dateHeaders(1, j)))If colIndex >= 5 And colIndex <= 35 Then ' E列到AI列If arrCalc(i, 6 + j)(1) > 0 Thenws2.Cells(i + 2, colIndex).value = arrCalc(i, 6 + j)(0) / arrCalc(i, 6 + j)(1)ws2.Cells(i + 2, colIndex).NumberFormat = "0.00%"End IfEnd IfEnd IfNext j' 功能6：异常项目统计ws2.Cells(i + 2, 36).value = labStats(i) ' AJ列ws2.Cells(i + 2, 37).value = colorStats(i) ' AK列ws2.Cells(i + 2, 38).value = reflectStats(i) ' AL列ws2.Range("AJ" & i + 2 & ":AL" & i + 2).HorizontalAlignment = xlCenter' 功能7：位置分布统计Dim totalPos As LongtotalPos = ngStats(i, 1) + ngStats(i, 2) + ngStats(i, 3) + ngStats(i, 4)If totalPos > 0 Then' 上ws2.Cells(i + 2, 39).value = ngStats(i, 1) / totalPos ' AM列' 中ws2.Cells(i + 2, 40).value = ngStats(i, 2) / totalPos ' AN列' 下ws2.Cells(i + 2, 41).value = ngStats(i, 3) / totalPos ' AO列' 整罩ws2.Cells(i + 2, 42).value = ngStats(i, 4) / totalPos ' AP列ws2.Range("AM" & i + 2 & ":AP" & i + 2).NumberFormat = "0.00%"ws2.Range("AM" & i + 2 & ":AP" & i + 2).HorizontalAlignment = xlCenterEnd IfNext i' 设置条件格式SetConditionalFormatting ws2.Range("D3:D" & 2 + dict.Count)For j = 5 To 35 ' E列到AI列If j <= ws2.Columns.Count ThenSetConditionalFormatting ws2.Range(ws2.Cells(3, j), ws2.Cells(2 + dict.Count, j))End IfNext j' 恢复设置Application.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomaticApplication.EnableEvents = TrueMsgBox "处理完成！共处理 " & dict.Count & " 条记录", vbInformation
End SubPrivate Sub SetConditionalFormatting(rng As Range)With rng.FormatConditions.Delete' 小于80%标红.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(ISNUMBER(" & rng.Cells(1, 1).Address(False, False) & ")," & rng.Cells(1, 1).Address(False, False) & "<0.8)".FormatConditions(1).Interior.Color = RGB(255, 0, 0)' 80%-90%标橙.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(ISNUMBER(" & rng.Cells(1, 1).Address(False, False) & ")," & rng.Cells(1, 1).Address(False, False) & ">=0.8," & rng.Cells(1, 1).Address(False, False) & "<0.9)".FormatConditions(2).Interior.Color = RGB(255, 165, 0)' 90%-98%标黄.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(ISNUMBER(" & rng.Cells(1, 1).Address(False, False) & ")," & rng.Cells(1, 1).Address(False, False) & ">=0.9," & rng.Cells(1, 1).Address(False, False) & "<0.98)".FormatConditions(3).Interior.Color = RGB(255, 255, 0)' 大于98%标绿.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(ISNUMBER(" & rng.Cells(1, 1).Address(False, False) & ")," & rng.Cells(1, 1).Address(False, False) & ">=0.98)".FormatConditions(4).Interior.Color = RGB(0, 255, 0)End With
End SubPrivate Sub QuickSort(arr() As Variant, ByVal first As Long, ByVal last As Long)Dim pivot As String, temp As VariantDim i As Long, j As LongIf first < last Thenpivot = arr((first + last) \ 2)i = firstj = lastDoDo While arr(i) < pivoti = i + 1LoopDo While arr(j) > pivotj = j - 1LoopIf i <= j Thentemp = arr(i)arr(i) = arr(j)arr(j) = tempi = i + 1j = j - 1End IfLoop Until i > jIf first < j Then QuickSort arr, first, jIf i < last Then QuickSort arr, i, lastEnd If
End Sub

6.镜片通过率圈数分析

分析1.1

Option Explicit
Sub ProcessLensData()Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As WorksheetDim startTime As Double: startTime = TimerApplication.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualApplication.EnableEvents = False' 设置工作表对象Set ws1 = ThisWorkbook.Sheets("测试记录")Set ws2 = ThisWorkbook.Sheets("镜片通过率圈数分析")Set ws3 = ThisWorkbook.Sheets("工艺&客户整理")' 1. 清除目标区域ws2.Range("A3:AP" & ws2.Rows.count).ClearContentsws2.Range("A3:AP" & ws2.Rows.count).ClearFormats' 2. 提取不重复机种件号组合Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")Dim lastRow1 As Long: lastRow1 = ws1.Cells(ws1.Rows.count, "A").End(xlUp).rowDim dataArr1 As Variant: dataArr1 = ws1.Range("A3:N" & lastRow1).valueDim startDate As Date: startDate = ws2.Range("L1").valueDim endDate As Date: endDate = ws2.Range("P1").value' 位置权重定义Dim posWeights As ObjectSet posWeights = CreateObject("Scripting.Dictionary")With posWeights.Add "上", 1: .Add "中", 1: .Add "下", 1.Add "上中", 2: .Add "上下", 2: .Add "中下", 2.Add "中上", 2: .Add "下中", 2: .Add "下上", 2.Add "整罩", 3End With' 提取有效数据Dim i As Long, j As Long, key As String, posKey As VariantFor i = 1 To UBound(dataArr1, 1)If IsDate(dataArr1(i, 1)) ThenIf dataArr1(i, 1) >= startDate And dataArr1(i, 1) <= endDate ThenIf IsNumeric(dataArr1(i, 8)) And dataArr1(i, 8) > 800 Thenkey = dataArr1(i, 7) & "|" & dataArr1(i, 8)If Not dict.Exists(key) Then dict.Add key, Array(dataArr1(i, 7), dataArr1(i, 8))End IfEnd IfEnd IfNext i' 排序并输出到sheet2Dim keys() As Variant: keys = dict.keysQuickSort keys, LBound(keys), UBound(keys)Dim outputArr() As VariantReDim outputArr(1 To dict.count, 1 To 3)For i = 0 To dict.count - 1outputArr(i + 1, 1) = Split(keys(i), "|")(0)  '机种outputArr(i + 1, 2) = Split(keys(i), "|")(1)  '件号Next i' 3. 匹配终端信息Dim lastRow3 As Long: lastRow3 = ws3.Cells(ws3.Rows.count, "A").End(xlUp).rowDim dataArr3 As Variant: dataArr3 = ws3.Range("A3:D" & lastRow3).valueDim terminalDict As Object: Set terminalDict = CreateObject("Scripting.Dictionary")For i = 1 To UBound(dataArr3, 1)key = dataArr3(i, 1) & "|" & dataArr3(i, 2)If Not terminalDict.Exists(key) Then terminalDict.Add key, dataArr3(i, 3)Next i' 填充终端信息并排序For i = 1 To dict.countkey = outputArr(i, 1) & "|" & outputArr(i, 2)outputArr(i, 3) = terminalDict(key)Next i' 按终端列排序QuickSortMulti outputArr, 3' 输出到工作表With ws2.Range("A3").Resize(dict.count, 3).Columns(1).value = Application.Index(outputArr, 0, 3) '终端.Columns(2).value = Application.Index(outputArr, 0, 1) '机种.Columns(3).value = Application.Index(outputArr, 0, 2) '件号.HorizontalAlignment = xlCenterEnd With' 4. 计算通过率Dim resultArr() As VariantReDim resultArr(1 To dict.count, 1 To 42)  'D列到AP列' 预加载所有需要的数据Dim judgeArr As Variant: judgeArr = ws1.Range("K3:K" & lastRow1).valueDim dateArr As Variant: dateArr = ws1.Range("A3:A" & lastRow1).valueDim modelArr As Variant: modelArr = ws1.Range("G3:G" & lastRow1).valueDim partArr As Variant: partArr = ws1.Range("H3:H" & lastRow1).valueDim positionArr As Variant: positionArr = ws1.Range("N3:N" & lastRow1).value' 日期列映射Dim dateColDict As Object: Set dateColDict = CreateObject("Scripting.Dictionary")For j = 5 To 35  'E到AI列If IsDate(ws2.Cells(2, j).value) ThendateColDict(ws2.Cells(2, j).value) = jEnd IfNext j' 处理每个机种件号组合For i = 1 To dict.countDim model As String: model = outputArr(i, 1)Dim part As String: part = outputArr(i, 2)Dim ngCount As Long, totalCount As LongDim dailyNG() As Long: ReDim dailyNG(5 To 35)Dim dailyTotal() As Long: ReDim dailyTotal(5 To 35)' 计算合计通过率For j = 1 To UBound(dateArr, 1)If IsDate(dateArr(j, 1)) ThenIf dateArr(j, 1) >= startDate And dateArr(j, 1) <= endDate ThenIf modelArr(j, 1) = model And partArr(j, 1) = part ThentotalCount = totalCount + 1If judgeArr(j, 1) = "NG" And Not IsEmpty(positionArr(j, 1)) ThenFor Each posKey In posWeights.keysIf InStr(1, positionArr(j, 1), posKey, vbTextCompare) > 0 ThenngCount = ngCount + posWeights(posKey)' 记录每日数据If dateColDict.Exists(dateArr(j, 1)) ThendailyNG(dateColDict(dateArr(j, 1))) = dailyNG(dateColDict(dateArr(j, 1))) + posWeights(posKey)End IfExit ForEnd IfNextEnd If' 记录每日总数If dateColDict.Exists(dateArr(j, 1)) ThendailyTotal(dateColDict(dateArr(j, 1))) = dailyTotal(dateColDict(dateArr(j, 1))) + 1End IfEnd IfEnd IfEnd IfNext j' 计算合计通过率If totalCount > 0 And (totalCount * 3) > 0 ThenresultArr(i, 1) = 1 - (ngCount / (totalCount * 3))  'D列End If' 计算每日通过率For j = 5 To 35If dailyTotal(j) > 0 And (dailyTotal(j) * 3) > 0 ThenresultArr(i, j - 3) = 1 - (dailyNG(j) / (dailyTotal(j) * 3))End IfNext jNext i' 批量写入结果ws2.Range("D3").Resize(dict.count, 42).value = resultArr' 设置百分比格式和条件格式Dim cell As RangeFor i = 1 To dict.count' 设置D列格式With ws2.Cells(i + 2, 4) 'D列.NumberFormat = "0.00%"ApplyCellColorScale .value, .InteriorEnd With' 设置E-AI列格式For j = 5 To 35With ws2.Cells(i + 2, j).NumberFormat = "0.00%"ApplyCellColorScale .value, .InteriorEnd WithNext jNext i' 恢复设置Application.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomaticApplication.EnableEvents = TrueMsgBox "处理完成，耗时：" & Round(Timer - startTime, 2) & "秒", vbInformation
End SubPrivate Sub QuickSort(arr() As Variant, ByVal first As Long, ByVal last As Long)Dim pivot As String, temp As VariantDim i As Long, j As LongIf first < last Thenpivot = arr((first + last) \ 2)i = firstj = lastDoDo While arr(i) < pivot: i = i + 1: LoopDo While arr(j) > pivot: j = j - 1: LoopIf i <= j Thentemp = arr(i): arr(i) = arr(j): arr(j) = tempi = i + 1: j = j - 1End IfLoop Until i > jIf first < j Then QuickSort arr, first, jIf i < last Then QuickSort arr, i, lastEnd If
End SubPrivate Sub QuickSortMulti(arr() As Variant, ByVal sortCol As Long)QuickSortMultiInternal arr, LBound(arr), UBound(arr), sortCol
End SubPrivate Sub QuickSortMultiInternal(arr() As Variant, ByVal first As Long, ByVal last As Long, ByVal sortCol As Long)Dim pivot As String, temp() As VariantDim i As Long, j As Long, k As LongIf first < last Thenpivot = arr((first + last) \ 2, sortCol)i = firstj = lastDoDo While arr(i, sortCol) < pivot: i = i + 1: LoopDo While arr(j, sortCol) > pivot: j = j - 1: LoopIf i <= j ThenReDim temp(LBound(arr, 2) To UBound(arr, 2))For k = LBound(arr, 2) To UBound(arr, 2)temp(k) = arr(i, k)arr(i, k) = arr(j, k)arr(j, k) = temp(k)Next ki = i + 1: j = j - 1End IfLoop Until i > jIf first < j Then QuickSortMultiInternal arr, first, j, sortColIf i < last Then QuickSortMultiInternal arr, i, last, sortColEnd If
End SubPrivate Sub ApplyCellColorScale(cellValue As Variant, cellInterior As Interior)If IsEmpty(cellValue) Or IsError(cellValue) ThencellInterior.ColorIndex = xlNoneExit SubEnd IfSelect Case cellValueCase Is >= 0.98cellInterior.Color = RGB(0, 176, 80) '绿色Case Is >= 0.9cellInterior.Color = RGB(255, 255, 0) '黄色Case Is >= 0.8cellInterior.Color = RGB(255, 192, 0) '橙色Case Is >= 0cellInterior.Color = RGB(255, 0, 0) '红色Case ElsecellInterior.ColorIndex = xlNoneEnd Select
End Sub

分析1.2

Option Explicit
Sub ProcessLargeData()Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As WorksheetDim lastRow1 As Long, lastRow2 As Long, lastRow3 As LongDim dict As Object, key As StringDim arr1 As Variant, arr2 As Variant, arr3 As VariantDim i As Long, j As Long, k As LongDim startDate As Date, endDate As DateDim dateCols As Collection, colIndex As VariantDim a As Long, b As Long, c As DoubleDim d As Long, e As Long, f As DoubleDim positionValue As LongApplication.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualApplication.EnableEvents = FalseSet ws1 = Worksheets("测试记录")Set ws2 = Worksheets("镜片通过率圈数分析")Set ws3 = Worksheets("工艺&客户整理")' 1. 清除sheet2 A3:AP区域ws2.Range("A3:AP" & ws2.Rows.Count).ClearContentsws2.Range("A3:AP" & ws2.Rows.Count).ClearFormats' 获取日期范围startDate = ws2.Range("L1").valueendDate = ws2.Range("P1").value' 2. 提取不重复机种和件号(件号>800)lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).rowlastRow3 = ws3.Cells(ws3.Rows.Count, "A").End(xlUp).rowSet dict = CreateObject("Scripting.Dictionary")arr1 = ws1.Range("A3:H" & lastRow1).valueFor i = 1 To UBound(arr1, 1)If IsDate(arr1(i, 1)) ThenIf arr1(i, 1) >= startDate And arr1(i, 1) <= endDate ThenIf IsNumeric(arr1(i, 8)) And arr1(i, 8) > 800 Thenkey = arr1(i, 7) & "|" & arr1(i, 8)If Not dict.Exists(key) Thendict.Add key, Array(arr1(i, 7), arr1(i, 8))End IfEnd IfEnd IfEnd IfNext i' 排序并输出到sheet2Dim keys() As Variant, temp As Variantkeys = dict.keys()' 冒泡排序(针对大数据量可考虑更高效算法)For i = 0 To UBound(keys) - 1For j = i + 1 To UBound(keys)If keys(i) > keys(j) Thentemp = keys(i)keys(i) = keys(j)keys(j) = tempEnd IfNext jNext i' 输出到sheet2ReDim arr2(1 To dict.Count, 1 To 2)For i = 0 To UBound(keys)arr2(i + 1, 1) = dict(keys(i))(0) '机种arr2(i + 1, 2) = dict(keys(i))(1) '件号Next iws2.Range("B3").Resize(UBound(arr2, 1), 2).value = arr2ws2.Range("B3:C" & 3 + UBound(arr2, 1) - 1).HorizontalAlignment = xlCenter' 3. 匹配终端并排序arr3 = ws3.Range("A3:C" & lastRow3).valuelastRow2 = ws2.Cells(ws2.Rows.Count, "B").End(xlUp).rowFor i = 3 To lastRow2For j = 1 To UBound(arr3, 1)If ws2.Cells(i, "B").value = arr3(j, 1) And _ws2.Cells(i, "C").value = arr3(j, 2) Thenws2.Cells(i, "A").value = arr3(j, 3)Exit ForEnd IfNext jNext i' 按终端排序ws2.Range("A3:C" & lastRow2).Sort Key1:=ws2.Range("A3"), Order1:=xlDescending, Header:=xlNows2.Range("A3:A" & lastRow2).HorizontalAlignment = xlCenter' 4. 计算合计通过率Dim dateDict As ObjectSet dateDict = CreateObject("Scripting.Dictionary")' 预构建日期列映射Set dateCols = New CollectionFor j = 5 To 35 'E到AI列If IsDate(ws2.Cells(2, j).value) ThenIf ws2.Cells(2, j).value >= startDate And ws2.Cells(2, j).value <= endDate ThendateCols.Add jdateDict(ws2.Cells(2, j).value) = jEnd IfEnd IfNext j' 处理大数据使用数组Dim dataArr As VariantdataArr = ws1.Range("A3:N" & lastRow1).valueFor i = 3 To lastRow2a = 0b = 0' 计算合计For k = 1 To UBound(dataArr, 1)If IsDate(dataArr(k, 1)) ThenIf dataArr(k, 1) >= startDate And dataArr(k, 1) <= endDate ThenIf dataArr(k, 7) = ws2.Cells(i, "B").value And _dataArr(k, 8) = ws2.Cells(i, "C").value Thenb = b + 1If Not IsEmpty(dataArr(k, 14)) ThenSelect Case TrueCase InStr(1, dataArr(k, 14), "上中") > 0, _InStr(1, dataArr(k, 14), "上下") > 0, _InStr(1, dataArr(k, 14), "中下") > 0, _InStr(1, dataArr(k, 14), "中上") > 0, _InStr(1, dataArr(k, 14), "下中") > 0, _InStr(1, dataArr(k, 14), "下上") > 0positionValue = 2Case InStr(1, dataArr(k, 14), "整罩") > 0positionValue = 3Case InStr(1, dataArr(k, 14), "上") > 0, _InStr(1, dataArr(k, 14), "中") > 0, _InStr(1, dataArr(k, 14), "下") > 0positionValue = 1Case ElsepositionValue = 0End SelectIf positionValue > 0 Thena = a + positionValueEnd IfEnd IfEnd IfEnd IfEnd IfNext kb = b * 3If b > 0 Thenc = 1 - (a / b)ws2.Cells(i, "D").value = cws2.Cells(i, "D").NumberFormat = "0.00%"' 设置颜色Select Case cCase Is >= 0.98ws2.Cells(i, "D").Interior.Color = RGB(0, 255, 0) '绿色Case Is >= 0.9ws2.Cells(i, "D").Interior.Color = RGB(255, 255, 0) '黄色Case Is >= 0.8ws2.Cells(i, "D").Interior.Color = RGB(255, 192, 0) '橙色Case Is >= 0ws2.Cells(i, "D").Interior.Color = RGB(255, 0, 0) '红色End SelectEnd If' 5. 计算每日通过率For Each colIndex In dateColsd = 0e = 0Dim currentDate As DatecurrentDate = ws2.Cells(2, colIndex).valueFor k = 1 To UBound(dataArr, 1)If IsDate(dataArr(k, 1)) ThenIf dataArr(k, 1) = currentDate ThenIf dataArr(k, 7) = ws2.Cells(i, "B").value And _dataArr(k, 8) = ws2.Cells(i, "C").value Thene = e + 1If Not IsEmpty(dataArr(k, 14)) ThenSelect Case TrueCase InStr(1, dataArr(k, 14), "上中") > 0, _InStr(1, dataArr(k, 14), "上下") > 0, _InStr(1, dataArr(k, 14), "中下") > 0, _InStr(1, dataArr(k, 14), "中上") > 0, _InStr(1, dataArr(k, 14), "下中") > 0, _InStr(1, dataArr(k, 14), "下上") > 0positionValue = 2Case InStr(1, dataArr(k, 14), "整罩") > 0positionValue = 3Case InStr(1, dataArr(k, 14), "上") > 0, _InStr(1, dataArr(k, 14), "中") > 0, _InStr(1, dataArr(k, 14), "下") > 0positionValue = 1Case ElsepositionValue = 0End SelectIf positionValue > 0 Thend = d + positionValueEnd IfEnd IfEnd IfEnd IfEnd IfNext ke = e * 3If e > 0 Thenf = 1 - (d / e)ws2.Cells(i, colIndex).value = fws2.Cells(i, colIndex).NumberFormat = "0.00%"' 设置颜色Select Case fCase Is >= 0.98ws2.Cells(i, colIndex).Interior.Color = RGB(0, 255, 0) '绿色Case Is >= 0.9ws2.Cells(i, colIndex).Interior.Color = RGB(255, 255, 0) '黄色Case Is >= 0.8ws2.Cells(i, colIndex).Interior.Color = RGB(255, 192, 0) '橙色Case Is >= 0ws2.Cells(i, colIndex).Interior.Color = RGB(255, 0, 0) '红色End SelectEnd IfNext colIndexNext iApplication.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomaticApplication.EnableEvents = TrueMsgBox "数据处理完成!", vbInformation
End Sub

8.镜筒通过率圈数分析

分析1.1

vba 高速处理excel 10万行以上数据
sheet1名称为测试记录，第二行为标题行，A2列标题测试日期，B2列标题班次，C2列标题测试员，D2列标题测试仪，E2列标题机台，F2列标题罩次，G2列标题机种，H2列标题件号，K2列标题判定，L2列标题异常项目，N2列标题位置，U2列标题终端，V2列标题工艺
sheet2名称为镜筒通过率圈数分析，第二行为标题行，A2列标题终端，B2列标题机种，C2列标题件号，D2列标题合计，E2：AI2分别为6/1-7/1日期，AJ2列标题LAB异常，AK2列标题膜色异常，AL2列标题反射率异常，AM2列标题上，AN2列标题中，AO2列标题下，AP2列标题整罩 ，L1单元格为起始日期，P1单元格为终止日期
sheet3名称为工艺&客户整理，第二行为标题行，A2列标题机种，B2列标题件号，C2列标题终端，D2列标题工艺
vba实现以下功能：
1）清除sheet2 A3:AP区域单元格内容以及单元格格式
2）提取sheet1 A3列日期 等于sheet2 起始日期L1 至 终止日期P1所有日期 且sheet1 G3列机种&H3列件号(H3列内容小于800)的不重复值，不重复值按机种和件号升序排列后，输出到sheet2 B3列&C3列，sheet2 B3&C3设置单元格居中
3）匹配sheet2 B3列机种&C3列件号等于sheet3 A3列机种&B3列件号时，sheet3 C3列内容到sheet2 A3列，按sheet2 A3列升序排列，sheet2,A3列设置单元格居中
定义“上”、“中”、“下”为1，“上中”、“上下”、“中下”、“中上”、“下中”、“下上”为2，“整罩”为3
4）计数a=(sheet1 G3列&H3列 等于sheet2 B3列&C3列 且sheet1 A3列日期 等于sheet2 L1起始日期至 P1终止日期所有日期 且sheet1 K3列为“NG”且sheet1 N列内容包含“上”、“中”、“下”、“上中”、“上下”、“中下”、“中上”、“下中”、“下上”"整罩”的个数)
计数b=(sheet1 G3列&H3列 等于sheet2 B3列&C3列 且sheet1 A3列日期 等于sheet2 L1起始日期至 P1终止日期所有日期 )*3
计算c=1-a/b，设置c格式，百分比保留2位小数，输出到sheet2 D3列，计算c值大于等于0%且小于80%填充红色,c值80%-90%填充橙色，c值90%-98%填充黄，c值98%以上填充绿,其它不填充颜色
5）计数d=(sheet1 G3列&H3列 等于sheet2 B3列&C3列 且sheet1 A3列日期 分别等于sheet2 L1起始日期至 P1终止日期且等于sheet2 E2:AI2 对应日期 且sheet1 K3列为“NG”且sheet1 N列内容包含“上”、“中”、“下”、“上中”、“上下”、“中下”、“中上”、“下中”、“下上”"整罩”的个数)
计数e=(sheet1 G3列&H3列 等于sheet2 B3列&C3列 且sheet1 A3列日期 分别等于sheet2 L1起始日期至 P1终止日期且等于sheet2 E2:AI2 对应日期 )*3
计算f=1-d/e，设置d格式，百分比保留2位小数，输出到E2：AI2日期等于L1至P1每个日期对应的列，计算f值大于等于0%且小于80%填充红色,f值80%-90%填充橙色，f值90%-98%填充黄色 ，f值98%以上填充绿色，其它不填充颜色
修正sheet2 A3排序失效问题

Option Explicit
Sub ProcessLensData()Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As WorksheetDim startTime As Double: startTime = TimerApplication.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualApplication.EnableEvents = False' 设置工作表对象Set ws1 = ThisWorkbook.Sheets("测试记录")Set ws2 = ThisWorkbook.Sheets("镜筒通过率圈数分析")Set ws3 = ThisWorkbook.Sheets("工艺&客户整理")' 1. 清除目标区域ws2.Range("A3:AP" & ws2.Rows.count).ClearContentsws2.Range("A3:AP" & ws2.Rows.count).ClearFormats' 2. 提取不重复机种件号组合Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")Dim lastRow1 As Long: lastRow1 = ws1.Cells(ws1.Rows.count, "A").End(xlUp).rowDim dataArr1 As Variant: dataArr1 = ws1.Range("A3:N" & lastRow1).valueDim startDate As Date: startDate = ws2.Range("L1").valueDim endDate As Date: endDate = ws2.Range("P1").value' 位置权重定义Dim posWeights As ObjectSet posWeights = CreateObject("Scripting.Dictionary")With posWeights.Add "上", 1: .Add "中", 1: .Add "下", 1.Add "上中", 2: .Add "上下", 2: .Add "中下", 2.Add "中上", 2: .Add "下中", 2: .Add "下上", 2.Add "整罩", 3End With' 提取有效数据Dim i As Long, j As Long, key As String, posKey As VariantFor i = 1 To UBound(dataArr1, 1)If IsDate(dataArr1(i, 1)) ThenIf dataArr1(i, 1) >= startDate And dataArr1(i, 1) <= endDate ThenIf IsNumeric(dataArr1(i, 8)) And dataArr1(i, 8) < 800 Thenkey = dataArr1(i, 7) & "|" & dataArr1(i, 8)If Not dict.Exists(key) Then dict.Add key, Array(dataArr1(i, 7), dataArr1(i, 8))End IfEnd IfEnd IfNext i' 排序并输出到sheet2Dim keys() As Variant: keys = dict.keysQuickSort keys, LBound(keys), UBound(keys)Dim outputArr() As VariantReDim outputArr(1 To dict.count, 1 To 3)For i = 0 To dict.count - 1outputArr(i + 1, 1) = Split(keys(i), "|")(0)  '机种outputArr(i + 1, 2) = Split(keys(i), "|")(1)  '件号Next i' 3. 匹配终端信息Dim lastRow3 As Long: lastRow3 = ws3.Cells(ws3.Rows.count, "A").End(xlUp).rowDim dataArr3 As Variant: dataArr3 = ws3.Range("A3:D" & lastRow3).valueDim terminalDict As Object: Set terminalDict = CreateObject("Scripting.Dictionary")For i = 1 To UBound(dataArr3, 1)key = dataArr3(i, 1) & "|" & dataArr3(i, 2)If Not terminalDict.Exists(key) Then terminalDict.Add key, dataArr3(i, 3)Next i' 填充终端信息并排序For i = 1 To dict.countkey = outputArr(i, 1) & "|" & outputArr(i, 2)outputArr(i, 3) = terminalDict(key)Next i' 按终端列排序QuickSortMulti outputArr, 3' 输出到工作表With ws2.Range("A3").Resize(dict.count, 3).Columns(1).value = Application.Index(outputArr, 0, 3) '终端.Columns(2).value = Application.Index(outputArr, 0, 1) '机种.Columns(3).value = Application.Index(outputArr, 0, 2) '件号.HorizontalAlignment = xlCenterEnd With' 4. 计算通过率Dim resultArr() As VariantReDim resultArr(1 To dict.count, 1 To 42)  'D列到AP列' 预加载所有需要的数据Dim judgeArr As Variant: judgeArr = ws1.Range("K3:K" & lastRow1).valueDim dateArr As Variant: dateArr = ws1.Range("A3:A" & lastRow1).valueDim modelArr As Variant: modelArr = ws1.Range("G3:G" & lastRow1).valueDim partArr As Variant: partArr = ws1.Range("H3:H" & lastRow1).valueDim positionArr As Variant: positionArr = ws1.Range("N3:N" & lastRow1).value' 日期列映射Dim dateColDict As Object: Set dateColDict = CreateObject("Scripting.Dictionary")For j = 5 To 35  'E到AI列If IsDate(ws2.Cells(2, j).value) ThendateColDict(ws2.Cells(2, j).value) = jEnd IfNext j' 处理每个机种件号组合For i = 1 To dict.countDim model As String: model = outputArr(i, 1)Dim part As String: part = outputArr(i, 2)Dim ngCount As Long, totalCount As LongDim dailyNG() As Long: ReDim dailyNG(5 To 35)Dim dailyTotal() As Long: ReDim dailyTotal(5 To 35)' 计算合计通过率For j = 1 To UBound(dateArr, 1)If IsDate(dateArr(j, 1)) ThenIf dateArr(j, 1) >= startDate And dateArr(j, 1) <= endDate ThenIf modelArr(j, 1) = model And partArr(j, 1) = part ThentotalCount = totalCount + 1If judgeArr(j, 1) = "NG" And Not IsEmpty(positionArr(j, 1)) ThenFor Each posKey In posWeights.keysIf InStr(1, positionArr(j, 1), posKey, vbTextCompare) > 0 ThenngCount = ngCount + posWeights(posKey)' 记录每日数据If dateColDict.Exists(dateArr(j, 1)) ThendailyNG(dateColDict(dateArr(j, 1))) = dailyNG(dateColDict(dateArr(j, 1))) + posWeights(posKey)End IfExit ForEnd IfNextEnd If' 记录每日总数If dateColDict.Exists(dateArr(j, 1)) ThendailyTotal(dateColDict(dateArr(j, 1))) = dailyTotal(dateColDict(dateArr(j, 1))) + 1End IfEnd IfEnd IfEnd IfNext j' 计算合计通过率If totalCount > 0 And (totalCount * 3) > 0 ThenresultArr(i, 1) = 1 - (ngCount / (totalCount * 3))  'D列End If' 计算每日通过率For j = 5 To 35If dailyTotal(j) > 0 And (dailyTotal(j) * 3) > 0 ThenresultArr(i, j - 3) = 1 - (dailyNG(j) / (dailyTotal(j) * 3))End IfNext jNext i' 批量写入结果ws2.Range("D3").Resize(dict.count, 42).value = resultArr' 设置百分比格式和条件格式Dim cell As RangeFor i = 1 To dict.count' 设置D列格式With ws2.Cells(i + 2, 4) 'D列.NumberFormat = "0.00%"ApplyCellColorScale .value, .InteriorEnd With' 设置E-AI列格式For j = 5 To 35With ws2.Cells(i + 2, j).NumberFormat = "0.00%"ApplyCellColorScale .value, .InteriorEnd WithNext jNext i' 恢复设置Application.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomaticApplication.EnableEvents = TrueMsgBox "处理完成，耗时：" & Round(Timer - startTime, 2) & "秒", vbInformation
End SubPrivate Sub QuickSort(arr() As Variant, ByVal first As Long, ByVal last As Long)Dim pivot As String, temp As VariantDim i As Long, j As LongIf first < last Thenpivot = arr((first + last) \ 2)i = firstj = lastDoDo While arr(i) < pivot: i = i + 1: LoopDo While arr(j) > pivot: j = j - 1: LoopIf i <= j Thentemp = arr(i): arr(i) = arr(j): arr(j) = tempi = i + 1: j = j - 1End IfLoop Until i > jIf first < j Then QuickSort arr, first, jIf i < last Then QuickSort arr, i, lastEnd If
End SubPrivate Sub QuickSortMulti(arr() As Variant, ByVal sortCol As Long)QuickSortMultiInternal arr, LBound(arr), UBound(arr), sortCol
End SubPrivate Sub QuickSortMultiInternal(arr() As Variant, ByVal first As Long, ByVal last As Long, ByVal sortCol As Long)Dim pivot As String, temp() As VariantDim i As Long, j As Long, k As LongIf first < last Thenpivot = arr((first + last) \ 2, sortCol)i = firstj = lastDoDo While arr(i, sortCol) < pivot: i = i + 1: LoopDo While arr(j, sortCol) > pivot: j = j - 1: LoopIf i <= j ThenReDim temp(LBound(arr, 2) To UBound(arr, 2))For k = LBound(arr, 2) To UBound(arr, 2)temp(k) = arr(i, k)arr(i, k) = arr(j, k)arr(j, k) = temp(k)Next ki = i + 1: j = j - 1End IfLoop Until i > jIf first < j Then QuickSortMultiInternal arr, first, j, sortColIf i < last Then QuickSortMultiInternal arr, i, last, sortColEnd If
End SubPrivate Sub ApplyCellColorScale(cellValue As Variant, cellInterior As Interior)If IsEmpty(cellValue) Or IsError(cellValue) ThencellInterior.ColorIndex = xlNoneExit SubEnd IfSelect Case cellValueCase Is >= 0.98cellInterior.Color = RGB(0, 176, 80) '绿色Case Is >= 0.9cellInterior.Color = RGB(255, 255, 0) '黄色Case Is >= 0.8cellInterior.Color = RGB(255, 192, 0) '橙色Case Is >= 0cellInterior.Color = RGB(255, 0, 0) '红色Case ElsecellInterior.ColorIndex = xlNoneEnd Select
End Sub

分析1.2

Option Explicit
Sub ProcessLargeData()Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As WorksheetDim lastRow1 As Long, lastRow2 As Long, lastRow3 As LongDim dict As Object, key As StringDim arr1 As Variant, arr2 As Variant, arr3 As VariantDim i As Long, j As Long, k As LongDim startDate As Date, endDate As DateDim dateCols As Collection, colIndex As VariantDim a As Long, b As Long, c As DoubleDim d As Long, e As Long, f As DoubleDim positionValue As LongApplication.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualApplication.EnableEvents = FalseSet ws1 = Worksheets("测试记录")Set ws2 = Worksheets("镜筒通过率圈数分析")Set ws3 = Worksheets("工艺&客户整理")' 1. 清除sheet2 A3:AP区域ws2.Range("A3:AP" & ws2.Rows.Count).ClearContentsws2.Range("A3:AP" & ws2.Rows.Count).ClearFormats' 获取日期范围startDate = ws2.Range("L1").valueendDate = ws2.Range("P1").value' 2. 提取不重复机种和件号(件号>800)lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).rowlastRow3 = ws3.Cells(ws3.Rows.Count, "A").End(xlUp).rowSet dict = CreateObject("Scripting.Dictionary")arr1 = ws1.Range("A3:H" & lastRow1).valueFor i = 1 To UBound(arr1, 1)If IsDate(arr1(i, 1)) ThenIf arr1(i, 1) >= startDate And arr1(i, 1) <= endDate ThenIf IsNumeric(arr1(i, 8)) And arr1(i, 8) < 800 Thenkey = arr1(i, 7) & "|" & arr1(i, 8)If Not dict.Exists(key) Thendict.Add key, Array(arr1(i, 7), arr1(i, 8))End IfEnd IfEnd IfEnd IfNext i' 排序并输出到sheet2Dim keys() As Variant, temp As Variantkeys = dict.keys()' 冒泡排序(针对大数据量可考虑更高效算法)For i = 0 To UBound(keys) - 1For j = i + 1 To UBound(keys)If keys(i) > keys(j) Thentemp = keys(i)keys(i) = keys(j)keys(j) = tempEnd IfNext jNext i' 输出到sheet2ReDim arr2(1 To dict.Count, 1 To 2)For i = 0 To UBound(keys)arr2(i + 1, 1) = dict(keys(i))(0) '机种arr2(i + 1, 2) = dict(keys(i))(1) '件号Next iws2.Range("B3").Resize(UBound(arr2, 1), 2).value = arr2ws2.Range("B3:C" & 3 + UBound(arr2, 1) - 1).HorizontalAlignment = xlCenter' 3. 匹配终端并排序arr3 = ws3.Range("A3:C" & lastRow3).valuelastRow2 = ws2.Cells(ws2.Rows.Count, "B").End(xlUp).rowFor i = 3 To lastRow2For j = 1 To UBound(arr3, 1)If ws2.Cells(i, "B").value = arr3(j, 1) And _ws2.Cells(i, "C").value = arr3(j, 2) Thenws2.Cells(i, "A").value = arr3(j, 3)Exit ForEnd IfNext jNext i' 按终端排序ws2.Range("A3:C" & lastRow2).Sort Key1:=ws2.Range("A3"), Order1:=xlDescending, Header:=xlNows2.Range("A3:A" & lastRow2).HorizontalAlignment = xlCenter' 4. 计算合计通过率Dim dateDict As ObjectSet dateDict = CreateObject("Scripting.Dictionary")' 预构建日期列映射Set dateCols = New CollectionFor j = 5 To 35 'E到AI列If IsDate(ws2.Cells(2, j).value) ThenIf ws2.Cells(2, j).value >= startDate And ws2.Cells(2, j).value <= endDate ThendateCols.Add jdateDict(ws2.Cells(2, j).value) = jEnd IfEnd IfNext j' 处理大数据使用数组Dim dataArr As VariantdataArr = ws1.Range("A3:N" & lastRow1).valueFor i = 3 To lastRow2a = 0b = 0' 计算合计For k = 1 To UBound(dataArr, 1)If IsDate(dataArr(k, 1)) ThenIf dataArr(k, 1) >= startDate And dataArr(k, 1) <= endDate ThenIf dataArr(k, 7) = ws2.Cells(i, "B").value And _dataArr(k, 8) = ws2.Cells(i, "C").value Thenb = b + 1If Not IsEmpty(dataArr(k, 14)) ThenSelect Case TrueCase InStr(1, dataArr(k, 14), "上中") > 0, _InStr(1, dataArr(k, 14), "上下") > 0, _InStr(1, dataArr(k, 14), "中下") > 0, _InStr(1, dataArr(k, 14), "中上") > 0, _InStr(1, dataArr(k, 14), "下中") > 0, _InStr(1, dataArr(k, 14), "下上") > 0positionValue = 2Case InStr(1, dataArr(k, 14), "整罩") > 0positionValue = 3Case InStr(1, dataArr(k, 14), "上") > 0, _InStr(1, dataArr(k, 14), "中") > 0, _InStr(1, dataArr(k, 14), "下") > 0positionValue = 1Case ElsepositionValue = 0End SelectIf positionValue > 0 Thena = a + positionValueEnd IfEnd IfEnd IfEnd IfEnd IfNext kb = b * 3If b > 0 Thenc = 1 - (a / b)ws2.Cells(i, "D").value = cws2.Cells(i, "D").NumberFormat = "0.00%"' 设置颜色Select Case cCase Is >= 0.98ws2.Cells(i, "D").Interior.Color = RGB(0, 255, 0) '绿色Case Is >= 0.9ws2.Cells(i, "D").Interior.Color = RGB(255, 255, 0) '黄色Case Is >= 0.8ws2.Cells(i, "D").Interior.Color = RGB(255, 192, 0) '橙色Case Is >= 0ws2.Cells(i, "D").Interior.Color = RGB(255, 0, 0) '红色End SelectEnd If' 5. 计算每日通过率For Each colIndex In dateColsd = 0e = 0Dim currentDate As DatecurrentDate = ws2.Cells(2, colIndex).valueFor k = 1 To UBound(dataArr, 1)If IsDate(dataArr(k, 1)) ThenIf dataArr(k, 1) = currentDate ThenIf dataArr(k, 7) = ws2.Cells(i, "B").value And _dataArr(k, 8) = ws2.Cells(i, "C").value Thene = e + 1If Not IsEmpty(dataArr(k, 14)) ThenSelect Case TrueCase InStr(1, dataArr(k, 14), "上中") > 0, _InStr(1, dataArr(k, 14), "上下") > 0, _InStr(1, dataArr(k, 14), "中下") > 0, _InStr(1, dataArr(k, 14), "中上") > 0, _InStr(1, dataArr(k, 14), "下中") > 0, _InStr(1, dataArr(k, 14), "下上") > 0positionValue = 2Case InStr(1, dataArr(k, 14), "整罩") > 0positionValue = 3Case InStr(1, dataArr(k, 14), "上") > 0, _InStr(1, dataArr(k, 14), "中") > 0, _InStr(1, dataArr(k, 14), "下") > 0positionValue = 1Case ElsepositionValue = 0End SelectIf positionValue > 0 Thend = d + positionValueEnd IfEnd IfEnd IfEnd IfEnd IfNext ke = e * 3If e > 0 Thenf = 1 - (d / e)ws2.Cells(i, colIndex).value = fws2.Cells(i, colIndex).NumberFormat = "0.00%"' 设置颜色Select Case fCase Is >= 0.98ws2.Cells(i, colIndex).Interior.Color = RGB(0, 255, 0) '绿色Case Is >= 0.9ws2.Cells(i, colIndex).Interior.Color = RGB(255, 255, 0) '黄色Case Is >= 0.8ws2.Cells(i, colIndex).Interior.Color = RGB(255, 192, 0) '橙色Case Is >= 0ws2.Cells(i, colIndex).Interior.Color = RGB(255, 0, 0) '红色End SelectEnd IfNext colIndexNext iApplication.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomaticApplication.EnableEvents = TrueMsgBox "数据处理完成!", vbInformation
End Sub

9.镜筒通过率罩次分析

分析1.2

Option Explicit
Sub ProcessMassiveData()' 性能优化设置Application.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualApplication.EnableEvents = FalseDim ws1 As Worksheet, ws2 As Worksheet, ws3 As WorksheetSet ws1 = Sheets("测试记录")Set ws2 = Sheets("镜筒通过率罩次分析")Set ws3 = Sheets("工艺&客户整理")' 功能1：清除Sheet2数据区域With ws2.Range("A3:AP" & ws2.Rows.Count).ClearContents.ClearFormatsEnd With' 获取日期范围Dim startDate As Date, endDate As DatestartDate = ws2.Range("L1").valueendDate = ws2.Range("P1").value' 功能2：提取并处理数据Dim dict As Object, arrData(), arrResult()   '声明一个名为dict的变量，类型为Object对象类型Set dict = CreateObject("Scripting.Dictionary") '绑定创建字典对象Dim lastRow As Long   'long 类型可存储-2147483648 到 2147483647lastRow = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).row' 将数据读入数组提升性能arrData = ws1.Range("A3:V" & lastRow).value' 筛选处理（日期范围+件号<800）Dim i As Long, comboKey As StringFor i = LBound(arrData) To UBound(arrData)  'LBound是用于获取数组下限最小索引的函数If IsDate(arrData(i, 1)) ThenIf arrData(i, 1) >= startDate And arrData(i, 1) <= endDate ThenIf Val(arrData(i, 8)) < 800 Then ' H列件号<800comboKey = arrData(i, 7) & "|" & arrData(i, 8) ' G|H列组合键If Not dict.Exists(comboKey) Thendict.Add comboKey, Array(arrData(i, 7), arrData(i, 8))End IfEnd IfEnd IfEnd IfNext i' 排序输出ReDim arrResult(1 To dict.Count, 1 To 2) '动态调整数组大小的语句，重新定义二维数组arrResult的维度'第一维大小设置为字典对象dict的元素数量1到dict.count，第二维固定为2列（1到2）'将字典数据转换为二维数组结构，准备输出到工作表的数据容器，动态构建结果集数组'会清除数组原有数据，只能调整最后一维的大小，此处第二维固定，dict.count必须大于0Dim keys() As Variantkeys = dict.keysQuickSort keys, LBound(keys), UBound(keys)'将字典对象的键提取到Variant数组，使用QuickSort排序，排序范围为LBound(keys), UBound(keys)' 填充结果数组Dim counter As Longcounter = 0For i = LBound(keys) To UBound(keys)counter = counter + 1arrResult(counter, 1) = dict(keys(i))(0) ' 机种arrResult(counter, 2) = dict(keys(i))(1) ' 件号Next i' 批量写入结果到Sheet2With ws2.Range("B3:C" & 2 + dict.Count).value = arrResult.HorizontalAlignment = xlCenter.VerticalAlignment = xlCenterEnd With' 功能3：跨表匹配终端信息并排序Dim arrMatch(), lastMatchRow As LonglastMatchRow = ws3.Cells(ws3.Rows.Count, "A").End(xlUp).rowIf lastMatchRow >= 3 ThenarrMatch = ws3.Range("A3:D" & lastMatchRow).value' 构建匹配字典Dim matchDict As ObjectSet matchDict = CreateObject("Scripting.Dictionary")For i = LBound(arrMatch) To UBound(arrMatch)matchDict(arrMatch(i, 1) & "|" & arrMatch(i, 2)) = arrMatch(i, 3)Next i' 执行匹配Dim outputArr(), matchKey As StringReDim outputArr(1 To dict.Count, 1 To 1)For i = 1 To dict.CountmatchKey = arrResult(i, 1) & "|" & arrResult(i, 2)outputArr(i, 1) = IIf(matchDict.Exists(matchKey), matchDict(matchKey), "")Next i' 写入终端数据With ws2.Range("A3:A" & 2 + dict.Count).value = outputArr.HorizontalAlignment = xlCenterEnd With' 按A列终端排序With ws2.Range("A3:C" & 2 + dict.Count).Sort Key1:=ws2.Range("A3"), Order1:=xlDescending, Header:=xlNo  'xlDescending  xlAscendingEnd WithEnd If' 获取日期列标题Dim dateHeaders() As VariantdateHeaders = ws2.Range("E2:AI2").value' 构建日期列索引字典Dim dateColDict As ObjectSet dateColDict = CreateObject("Scripting.Dictionary")For i = LBound(dateHeaders, 2) To UBound(dateHeaders, 2)If IsDate(dateHeaders(1, i)) ThenIf dateHeaders(1, i) >= startDate And dateHeaders(1, i) <= endDate ThendateColDict(CLng(dateHeaders(1, i))) = i + 4 ' E列是第5列End IfEnd IfNext i' 构建机种件号字典用于快速查找Dim itemDict As ObjectSet itemDict = CreateObject("Scripting.Dictionary")For i = 1 To dict.CountitemDict(ws2.Cells(i + 2, 2).value & "|" & ws2.Cells(i + 2, 3).value) = iNext i' 初始化统计数组Dim arrCalc(), calcRow As Long, j As Long'Debug.Print dict.count,ReDim arrCalc(1 To dict.Count, 1 To 37) ' 0:总通过率 1-4:位置统计 5-20:日期列统计21' 初始化异常统计数组Dim ngStats() As LongReDim ngStats(1 To dict.Count, 1 To 4) ' 上中下整罩计数Dim labStats() As Long, colorStats() As Long, reflectStats() As LongReDim labStats(1 To dict.Count)ReDim colorStats(1 To dict.Count)ReDim reflectStats(1 To dict.Count)For i = 1 To dict.CountarrCalc(i, 1) = Array(0, 0) ' 总通过率(OK数,总数)For j = 2 To 5arrCalc(i, j) = Array(0, 0) ' 位置统计(特定位置数,总NG数)Next jFor j = 6 To 37 '21arrCalc(i, j) = Array(0, 0) ' 日期列统计(OK数,总数)Next jNext i' 计算统计数据Dim itemIndex As Long, posText As String, currentDate As LongFor calcRow = LBound(arrData) To UBound(arrData)If IsDate(arrData(calcRow, 1)) ThencurrentDate = CLng(arrData(calcRow, 1))If currentDate >= CLng(startDate) And currentDate <= CLng(endDate) ThencomboKey = arrData(calcRow, 7) & "|" & arrData(calcRow, 8)If itemDict.Exists(comboKey) ThenitemIndex = itemDict(comboKey)' 总统计arrCalc(itemIndex, 1)(1) = arrCalc(itemIndex, 1)(1) + 1 ' 总数+1If UCase(arrData(calcRow, 11)) = "OK" ThenarrCalc(itemIndex, 1)(0) = arrCalc(itemIndex, 1)(0) + 1 ' OK数+1End If' 日期列统计If dateColDict.Exists(currentDate) ThenDim colIndex As LongcolIndex = dateColDict(currentDate) - 4 ' 转换为dateHeaders索引If colIndex >= LBound(dateHeaders, 2) And colIndex <= UBound(dateHeaders, 2) Then'Debug.Print LBound(dateHeaders, 2), itemIndex, 6 + colIndexarrCalc(itemIndex, 6 + colIndex)(1) = arrCalc(itemIndex, 6 + colIndex)(1) + 1'arrCalc是数组变量名，（itemIndex,6+colIndex）表示访问二维数组的指定行列，外层的1表示第一个索引值'Debug.Print arrCalc(itemIndex, 6 + colIndex)(1)If UCase(arrData(calcRow, 11)) = "OK" ThenarrCalc(itemIndex, 6 + colIndex)(0) = arrCalc(itemIndex, 6 + colIndex)(0) + 1End IfEnd IfEnd If' NG统计If UCase(arrData(calcRow, 11)) = "NG" Then' 异常项目统计If InStr(arrData(calcRow, 12), "LAB") > 0 Then labStats(itemIndex) = labStats(itemIndex) + 1If InStr(arrData(calcRow, 12), "膜色") > 0 Then colorStats(itemIndex) = colorStats(itemIndex) + 1If InStr(arrData(calcRow, 12), "反射率") > 0 Then reflectStats(itemIndex) = reflectStats(itemIndex) + 1' 位置统计posText = arrData(calcRow, 14)If InStr(posText, "上") > 0 Then ngStats(itemIndex, 1) = ngStats(itemIndex, 1) + 1If InStr(posText, "中") > 0 Then ngStats(itemIndex, 2) = ngStats(itemIndex, 2) + 1If InStr(posText, "下") > 0 Then ngStats(itemIndex, 3) = ngStats(itemIndex, 3) + 1If InStr(posText, "整罩") > 0 Then ngStats(itemIndex, 4) = ngStats(itemIndex, 4) + 1End IfEnd IfEnd IfEnd IfNext calcRow' 写入统计结果For i = 1 To dict.Count' 功能4：合计通过率If arrCalc(i, 1)(1) > 0 Thenws2.Cells(i + 2, 4).value = arrCalc(i, 1)(0) / arrCalc(i, 1)(1)ws2.Cells(i + 2, 4).NumberFormat = "0.00%"End If' 功能5：每日通过率For j = LBound(dateHeaders, 2) To UBound(dateHeaders, 2)If dateColDict.Exists(CLng(dateHeaders(1, j))) ThencolIndex = dateColDict(CLng(dateHeaders(1, j)))If colIndex >= 5 And colIndex <= 35 Then ' E列到AI列If arrCalc(i, 6 + j)(1) > 0 Thenws2.Cells(i + 2, colIndex).value = arrCalc(i, 6 + j)(0) / arrCalc(i, 6 + j)(1)ws2.Cells(i + 2, colIndex).NumberFormat = "0.00%"End IfEnd IfEnd IfNext j' 功能6：异常项目统计ws2.Cells(i + 2, 36).value = labStats(i) ' AJ列ws2.Cells(i + 2, 37).value = colorStats(i) ' AK列ws2.Cells(i + 2, 38).value = reflectStats(i) ' AL列ws2.Range("AJ" & i + 2 & ":AL" & i + 2).HorizontalAlignment = xlCenter' 功能7：位置分布统计Dim totalPos As LongtotalPos = ngStats(i, 1) + ngStats(i, 2) + ngStats(i, 3) + ngStats(i, 4)If totalPos > 0 Then' 上ws2.Cells(i + 2, 39).value = ngStats(i, 1) / totalPos ' AM列' 中ws2.Cells(i + 2, 40).value = ngStats(i, 2) / totalPos ' AN列' 下ws2.Cells(i + 2, 41).value = ngStats(i, 3) / totalPos ' AO列' 整罩ws2.Cells(i + 2, 42).value = ngStats(i, 4) / totalPos ' AP列ws2.Range("AM" & i + 2 & ":AP" & i + 2).NumberFormat = "0.00%"ws2.Range("AM" & i + 2 & ":AP" & i + 2).HorizontalAlignment = xlCenterEnd IfNext i' 设置条件格式SetConditionalFormatting ws2.Range("D3:D" & 2 + dict.Count)For j = 5 To 35 ' E列到AI列If j <= ws2.Columns.Count ThenSetConditionalFormatting ws2.Range(ws2.Cells(3, j), ws2.Cells(2 + dict.Count, j))End IfNext j' 恢复设置Application.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomaticApplication.EnableEvents = TrueMsgBox "处理完成！共处理 " & dict.Count & " 条记录", vbInformation
End SubPrivate Sub SetConditionalFormatting(rng As Range)With rng.FormatConditions.Delete' 小于80%标红.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(ISNUMBER(" & rng.Cells(1, 1).Address(False, False) & ")," & rng.Cells(1, 1).Address(False, False) & "<0.8)".FormatConditions(1).Interior.Color = RGB(255, 0, 0)' 80%-90%标橙.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(ISNUMBER(" & rng.Cells(1, 1).Address(False, False) & ")," & rng.Cells(1, 1).Address(False, False) & ">=0.8," & rng.Cells(1, 1).Address(False, False) & "<0.9)".FormatConditions(2).Interior.Color = RGB(255, 165, 0)' 90%-98%标黄.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(ISNUMBER(" & rng.Cells(1, 1).Address(False, False) & ")," & rng.Cells(1, 1).Address(False, False) & ">=0.9," & rng.Cells(1, 1).Address(False, False) & "<0.98)".FormatConditions(3).Interior.Color = RGB(255, 255, 0)' 大于98%标绿.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(ISNUMBER(" & rng.Cells(1, 1).Address(False, False) & ")," & rng.Cells(1, 1).Address(False, False) & ">=0.98)".FormatConditions(4).Interior.Color = RGB(0, 255, 0)End With
End SubPrivate Sub QuickSort(arr() As Variant, ByVal first As Long, ByVal last As Long)Dim pivot As String, temp As VariantDim i As Long, j As LongIf first < last Thenpivot = arr((first + last) \ 2)i = firstj = lastDoDo While arr(i) < pivoti = i + 1LoopDo While arr(j) > pivotj = j - 1LoopIf i <= j Thentemp = arr(i)arr(i) = arr(j)arr(j) = tempi = i + 1j = j - 1End IfLoop Until i > jIf first < j Then QuickSort arr, first, jIf i < last Then QuickSort arr, i, lastEnd If
End Sub

---

总结

分享：
一个人要忍耐这样的羞辱，这本身就需要更大的勇气，当一个人的心中有种更高的目标去攀登时，他就不会在意脚下的泥泞，他才可能用最平静的方式去面对一般人难以忍受的痛苦；