系列文章目录
文章目录
前言
一、外观报表
1.产能
Sub ProcessInspectionData()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim lastRow1 As Long, lastRow3 As Long
Dim dateCol As Range, empRange As Range
Dim i As Long, j As Long, k As Long
Dim count As Long, holeCount As Long
Dim okHoles As String, ngHoles As String
Dim 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).Row
For i = 4 To lastRow1
checkDate = ws1.Cells(i, "B").value
inspector = ws1.Cells(i, "O").value
okHoles = ws1.Cells(i, "J").value
ngHoles = ws1.Cells(i, "K").value
' 计算穴号总数
holeCount = CountHoles(okHoles) + CountHoles(ngHoles)
' 查找匹配的日期列
For j = 1 To dateCol.Columns.count
If dateCol.Cells(1, j).value = checkDate Then
' 情况1: J列和K列均为空
If okHoles = "" And ngHoles = "" Then
Set empRange = ws2.Range("D3:D22")
For k = 1 To empRange.Rows.count
If empRange.Cells(k, 1).value = inspector Then
ws2.Cells(k + 2, j + 5).value = Nz(ws2.Cells(k + 2, j + 5).value) + 3
Exit For
End If
Next k
' 情况2: 有穴号但总数<3
ElseIf holeCount > 0 And holeCount < 3 Then
Set empRange = ws2.Range("D23:D42")
For k = 1 To empRange.Rows.count
If empRange.Cells(k, 1).value = inspector Then
ws2.Cells(k + 22, j + 5).value = Nz(ws2.Cells(k + 22, j + 5).value) + 3
Exit For
End If
Next k
' 情况3: 有穴号且总数>=3
ElseIf holeCount >= 3 Then
Set empRange = ws2.Range("D23:D42")
For k = 1 To empRange.Rows.count
If empRange.Cells(k, 1).value = inspector Then
ws2.Cells(k + 22, j + 5).value = Nz(ws2.Cells(k + 22, j + 5).value) + holeCount
Exit For
End If
Next k
End If
Exit For
End If
Next j
Next i
' 处理镜筒抽检履历(Sheet3)
lastRow3 = ws3.Cells(ws3.Rows.count, "B").End(xlUp).Row
For i = 4 To lastRow3
checkDate = ws3.Cells(i, "B").value
inspector = ws3.Cells(i, "N").value
okHoles = ws3.Cells(i, "I").value
ngHoles = ws3.Cells(i, "J").value
' 计算穴号总数
holeCount = CountHoles(okHoles) + CountHoles(ngHoles)
' 查找匹配的日期列
For j = 1 To dateCol.Columns.count
If dateCol.Cells(1, j).value = checkDate Then
' 情况4: 有穴号但总数<3
If holeCount > 0 And holeCount < 3 Then
Set empRange = ws2.Range("D43:D62")
For k = 1 To empRange.Rows.count
If empRange.Cells(k, 1).value = inspector Then
ws2.Cells(k + 42, j + 5).value = Nz(ws2.Cells(k + 42, j + 5).value) + 3
Exit For
End If
Next k
' 情况5: 有穴号且总数>=3
ElseIf holeCount >= 3 Then
Set empRange = ws2.Range("D43:D62")
For k = 1 To empRange.Rows.count
If empRange.Cells(k, 1).value = inspector Then
ws2.Cells(k + 42, j + 5).value = Nz(ws2.Cells(k + 42, j + 5).value) + holeCount
Exit For
End If
Next k
End If
Exit For
End If
Next j
Next i
' 计算总和(D63:D82)
For j = 1 To dateCol.Columns.count
For k = 1 To 20
ws2.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 Then
ws2.Cells(k + 62, j + 5).value = ""
End If
Next k
Next j
MsgBox "产能汇总完成!", vbInformation
End Sub
Function CountHoles(holeStr As String) As Long
If holeStr = "" Then Exit Function
CountHoles = UBound(Split(holeStr, "+")) + 1
End Function
Function Nz(value As Variant) As Long
If IsEmpty(value) Or value = "" Then
Nz = 0
Else
Nz = CLng(value)
End If
End Function
2.固定伤排查
Sub ExtractAndMarkLensData()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim dict As Object, okDict As Object, ngDict As Object
Dim lastRow As Long, i As Long, j As Long
Dim startDate As Date, endDate As Date
Dim outputRow As Long, colIndex As Integer
Dim key As String, numbers As Variant
Dim item As Variant, sortedItems(), temp
Application.ScreenUpdating = False
Set 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 Next
startDate = CDate(ws2.Range("A3").value)
endDate = CDate(ws2.Range("B3").value)
On Error GoTo 0
If startDate = 0 Or endDate = 0 Then
MsgBox "日期格式错误，请检查A3/B3单元格", vbCritical
Exit Sub
End If
lastRow = ws1.Cells(ws1.Rows.count, "B").End(xlUp).Row
ws2.Range("A5:AM" & ws2.Rows.count).ClearContents
ws2.Range("A5:AM" & ws2.Rows.count).Interior.ColorIndex = xlNone
' 数据收集阶段
For i = 4 To lastRow
Dim currentDate As Date
currentDate = CDate(ws1.Cells(i, "B").value)
If currentDate >= startDate And currentDate <= endDate Then
key = ws1.Cells(i, "G").value & "|" & ws1.Cells(i, "H").value & "|" & ws1.Cells(i, "I").value
' 存储基础数据
If Not dict.exists(key) Then
dict.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, key
ProcessHoleNumbers ws1.Cells(i, "J").value, okDict, key
End If
Next i
' 将字典项转换为数组并排序（修正下标越界问题）
If dict.count > 0 Then
ReDim sortedItems(1 To dict.count)
i = 1
For Each item In dict.Items
sortedItems(i) = item
i = i + 1
Next
' 冒泡排序按H列和I列双重排序
' === 三重排序开始 ===
For i = 1 To UBound(sortedItems) - 1
For j = i + 1 To UBound(sortedItems)
' 第一优先级：H列（机种）
If sortedItems(i)(1) > sortedItems(j)(1) Then
temp = sortedItems(i)
sortedItems(i) = sortedItems(j)
sortedItems(j) = temp
' H列相同时比较I列
ElseIf sortedItems(i)(1) = sortedItems(j)(1) Then
If sortedItems(i)(2) > sortedItems(j)(2) Then
temp = sortedItems(i)
sortedItems(i) = sortedItems(j)
sortedItems(j) = temp
' H列和I列都相同时比较G列
ElseIf sortedItems(i)(2) = sortedItems(j)(2) Then
If sortedItems(i)(0) > sortedItems(j)(0) Then
temp = sortedItems(i)
sortedItems(i) = sortedItems(j)
sortedItems(j) = temp
End If
End If
End If
Next j
Next i
' === 三重排序结束 ===
End If
' 数据输出阶段
outputRow = 5
If dict.count > 0 Then
For 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) Then
numbers = Split(ngDict(key), "+")
For Each num In numbers
If IsNumeric(num) Then
colIndex = CInt(num) + 3
If colIndex >= 4 And colIndex <= 39 Then
With ws2.Cells(outputRow, colIndex)
.value = "NG"
.Interior.Color = RGB(255, 0, 0)
End With
End If
End If
Next
End If
' 标记OK穴号（绿色，排除已标记NG的）
If okDict.exists(key) Then
numbers = Split(okDict(key), "+")
For Each num In numbers
If IsNumeric(num) Then
colIndex = CInt(num) + 3
If colIndex >= 4 And colIndex <= 39 Then
If ws2.Cells(outputRow, colIndex).value <> "NG" Then
With ws2.Cells(outputRow, colIndex)
.value = "OK"
.Interior.Color = RGB(0, 255, 0)
End With
End If
End If
End If
Next
End If
outputRow = outputRow + 1
Next
End If
Application.ScreenUpdating = True
MsgBox "处理完成！共提取 " & dict.count & " 条记录", vbInformation
End Sub
Private Sub ProcessHoleNumbers(holeStr As String, ByRef dict As Object, key As String)
If holeStr <> "" Then
Dim numbers As Variant, num As Variant
numbers = Split(holeStr, "+")
For Each num In numbers
If IsNumeric(num) Then
If Not dict.exists(key) Then
dict.Add key, num
ElseIf InStr(dict(key), num) = 0 Then
dict(key) = dict(key) & "+" & num
End If
End If
Next
End If
End Sub
3.镜片不良TOP
Sub CalculateLensDefects()
Dim srcSheet As Worksheet, dstSheet As Worksheet
Dim lastRow As Long, i As Long, col As Long
Dim startDate As Date, endDate As Date
Dim machineType As String
Dim defectTitles(1 To 20) As String
Dim 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 38
defectTitles(col - 18) = srcSheet.Cells(3, col).value
dstSheet.Cells(18 + (col - 18), "Z").value = defectTitles(col - 18)
Next col
' 获取筛选条件
startDate = dstSheet.Range("AA2").value
endDate = dstSheet.Range("AA4").value
machineType = Trim(dstSheet.Range("AA11").value)
' 初始化统计数组
For i = 1 To 20
defectSums(i) = 0
Next 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 38
If IsNumeric(srcSheet.Cells(i, col).value) Then
defectSums(col - 18) = defectSums(col - 18) + srcSheet.Cells(i, col).value
End If
Next col
End If
End If
Next i
' 输出统计结果到AA列（S列和→AA19，T列和→AA20...）
For i = 1 To 20
dstSheet.Cells(18 + i, "AA").value = defectSums(i)
Next i
' 按缺陷数量升序排序（Z19:AA38区域）
With dstSheet.Range("Z19:AA38")
.Sort Key1:=.Columns(2), Order1:=xlDescending, Header:=xlNo 'xlAscending
End With
MsgBox "镜片质量分析完成：" & vbCrLf & _
"统计时段：" & startDate & " 至 " & endDate & vbCrLf & _
IIf(machineType <> "", "指定机种：" & machineType, "全部机种"), _
vbInformation, "操作完成"
End Sub
4.镜片公式计算
Option Explicit
Sub ProcessLensData()
Dim wsLens As Worksheet, wsData As Worksheet
Dim lastRow As Long, i As Long
Dim missingList As String, errorLog As String
Dim dict As Object, startDate As Date, endDate As Date
Set dict = CreateObject("Scripting.Dictionary")
Set wsLens = Sheets("镜片抽检履历")
Set wsData = Sheets("单板数整理")
' 获取日期范围
With wsLens
startDate = .Range("M2").value
endDate = .Range("Q2").value
End With
' 构建机种件号字典
With wsData
For i = 2 To .Cells(.Rows.count, 1).End(xlUp).Row
dict(.Cells(i, 1).value & "|" & .Cells(i, 2).value) = .Cells(i, 3).value
Next
End With
' 主处理流程
With wsLens
lastRow = .Cells(.Rows.count, 2).End(xlUp).Row
For i = 4 To lastRow
On Error Resume Next
If IsDate(.Cells(i, 2).value) Then
If .Cells(i, 2).value >= startDate And .Cells(i, 2).value <= endDate Then
ProcessLensRow .Rows(i), dict, missingList, errorLog
End If
End If
Next
End With
' 输出结果
If Len(missingList) > 0 Then MsgBox "未匹配记录：" & vbCrLf & missingList
If Len(errorLog) > 0 Then MsgBox "处理错误：" & errorLog
MsgBox "镜片抽检数据处理完成！", vbInformation
End Sub
Private Sub ProcessLensRow(rng As Range, dict As Object, ByRef missList As String, ByRef errLog As String)
Dim key As String, numCount As Integer
On Error GoTo ErrorHandler
' 任务1：单板数匹配
key = rng.Cells(1, 8).value & "|" & rng.Cells(1, 9).value
If dict.exists(key) Then
rng.Cells(1, 12).value = dict(key)
Else
rng.Cells(1, 12).value = "请录入该机种单板数"
missList = missList & key & vbCrLf
End 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 With
Exit Sub
ErrorHandler:
errLog = errLog & "行" & rng.Row & "列" & Split(Err.Source, "$")(1) & "; "
End Sub
5.镜片良率计算
Option Explicit
Sub CalculateYieldAndAverage()
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim lastRow As Long, i As Long, j As Long, k As Long
Dim dictMachine As Object, arrMachines(), arrDates()
Dim arrResults(), totalCount As Long, rejectCount As Long
Dim targetDate As Date, currentMachine As String
Dim 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).Row
For i = 4 To lastRow
currentMachine = Trim(wsSource.Cells(i, "H").value)
If currentMachine <> "" And Not dictMachine.exists(currentMachine) Then
dictMachine.Add currentMachine, 1
End If
Next i
' 排序并输出机种到A列
arrMachines = dictMachine.keys
Call 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) + 1
For j = 1 To UBound(arrDates, 2)
targetDate = arrDates(1, j)
totalCount = 0
rejectCount = 0
' 统计符合条件的数据
For k = 4 To lastRow
If wsSource.Cells(k, "H").value = arrMachines(i - 1) And _
wsSource.Cells(k, "B").value = targetDate Then
totalCount = totalCount + 1
If wsSource.Cells(k, "P").value = "退" Then
rejectCount = rejectCount + 1
End If
End If
Next k
' 计算良率百分比
If totalCount > 0 Then
arrResults(i, j) = Round((totalCount - rejectCount) / totalCount, 4)
End If
Next j
Next 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) + 1
sumValues = 0
countValues = 0
For j = 1 To UBound(arrDates, 2)
If Not IsEmpty(arrResults(i, j)) Then
sumValues = sumValues + arrResults(i, j)
countValues = countValues + 1
End If
Next j
If countValues > 0 Then
wsTarget.Cells(2 + i, "B").value = Round(sumValues / countValues, 4)
End If
Next 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 Long
Dim temp As Variant
For i = LBound(arr) To UBound(arr) - 1
For j = i + 1 To UBound(arr)
If arr(i) > arr(j) Then
temp = arr(i)
arr(i) = arr(j)
arr(j) = temp
End If
Next j
Next i
End Sub
6.镜片批退率
Sub CalculateYieldRate()
Dim wsData As Worksheet, wsReport As Worksheet
Dim startDate As Date, endDate As Date
Dim lastRow As Long, dict As Object
Dim arrData(), arrResult(), outputRow As Long
Dim i As Long, key As Variant, isSingleDate As Boolean
' 初始化设置
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
Set 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")) Then
MsgBox "请在AA2和AA4单元格输入有效日期", vbCritical
Exit Sub
End If
On Error Resume Next
startDate = CDate(wsReport.Range("AA2").value)
endDate = CDate(wsReport.Range("AA4").value)
If Err.Number <> 0 Then
MsgBox "日期格式不正确，请检查AA2和AA4单元格", vbCritical
Exit Sub
End If
On Error GoTo ErrorHandler
' 判断是单日期还是日期范围
isSingleDate = (DateDiff("d", startDate, endDate) = 0)
' 数据加载
lastRow = wsData.Cells(wsData.Rows.count, "B").End(xlUp).Row
If lastRow < 4 Then
MsgBox "抽检履历表无有效数据", vbExclamation
Exit Sub
End If
arrData = wsData.Range("B4:R" & lastRow).value
' 核心统计逻辑
For i = LBound(arrData) To UBound(arrData)
If IsDate(arrData(i, 1)) Then
Dim currentDate As Date
currentDate = CDate(arrData(i, 1))
' 检查日期是否符合条件
If (isSingleDate And DateValue(currentDate) = DateValue(startDate)) Or _
(Not isSingleDate And currentDate >= startDate And currentDate <= endDate) Then
Dim model As String
model = Trim(CStr(arrData(i, 7)))
' 跳过空机种
If model = "" Then GoTo NextItem
' 初始化字典项
If Not dict.exists(model) Then
dict.Add model, Array(0, 0) ' (总批次, 退批次)
End If
' 统计总数和退料数（不使用total = dict(key)(0)方式）
dict(model)(0) = dict(model)(0) + 1
If Trim(arrData(i, 15)) = "退" Then
dict(model)(1) = dict(model)(1) + 1
End If
End If
End If
NextItem:
Next i
' 结果输出
If dict.count > 0 Then
ReDim arrResult(1 To dict.count, 1 To 4)
outputRow = 1
' 使用字典键进行计数统计
For Each key In dict.keys
Dim total As Long, reject As Long
total = 0
reject = 0
' 重新计数（不使用dict(key)(0)方式）
For i = LBound(arrData) To UBound(arrData)
If IsDate(arrData(i, 1)) Then
currentDate = CDate(arrData(i, 1))
If (isSingleDate And DateValue(currentDate) = DateValue(startDate)) Or _
(Not isSingleDate And currentDate >= startDate And currentDate <= endDate) Then
If Trim(CStr(arrData(i, 7))) = key Then
total = total + 1
If Trim(arrData(i, 15)) = "退" Then
reject = reject + 1
End If
End If
End If
End If
Next i
arrResult(outputRow, 1) = key
arrResult(outputRow, 2) = total
arrResult(outputRow, 3) = reject
If total > 0 Then
arrResult(outputRow, 4) = reject / total
Else
arrResult(outputRow, 4) = 0
End If
outputRow = outputRow + 1
Next key
With 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:=xlNo
End If
End With
End If
Application.ScreenUpdating = True
MsgBox "处理完成！共统计 " & dict.count & " 个机种", vbInformation
Exit Sub
ErrorHandler:
Application.ScreenUpdating = True
MsgBox "错误 " & Err.Number & ": " & Err.Description, vbCritical
End Sub
7.镜筒不良TOP
Sub CalculateLensDefects()
Dim srcSheet As Worksheet, dstSheet As Worksheet
Dim lastRow As Long, i As Long, col As Long
Dim startDate As Date, endDate As Date
Dim machineType As String
Dim defectTitles(1 To 12) As String
Dim 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 29
defectTitles(col - 17) = srcSheet.Cells(3, col).value
dstSheet.Cells(18 + (col - 17), "AH").value = defectTitles(col - 17)
Next col
' 获取筛选条件
startDate = dstSheet.Range("AI2").value
endDate = dstSheet.Range("AI4").value
machineType = Trim(dstSheet.Range("AI11").value)
' 初始化统计数组
For i = 1 To 12
defectSums(i) = 0
Next 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 29
If IsNumeric(srcSheet.Cells(i, col).value) Then
defectSums(col - 17) = defectSums(col - 17) + srcSheet.Cells(i, col).value
End If
Next col
End If
End If
Next i
' 输出统计结果到AI列（R列和→AI19，S列和→AI20...）
For i = 1 To 12
dstSheet.Cells(18 + i, "AI").value = defectSums(i)
Next i
' 按缺陷数量升序排序（AH19:AI30区域）
With dstSheet.Range("AH19:AI30")
.Sort Key1:=.Columns(2), Order1:=xlDescending, Header:=xlNo
End With
MsgBox "镜筒质量分析完成：" & vbCrLf & _
"统计时段：" & startDate & " 至 " & endDate & vbCrLf & _
IIf(machineType <> "", "指定机种：" & machineType, "全部机种"), _
vbInformation, "操作完成"
End Sub
8.镜筒公式计算
Option Explicit
Sub ProcessBarrelData()
Dim wsBarrel As Worksheet, wsData As Worksheet
Dim lastRow As Long, i As Long
Dim missingList As String, errorLog As String
Dim dict As Object, startDate As Date, endDate As Date
Set dict = CreateObject("Scripting.Dictionary")
Set wsBarrel = Sheets("镜筒抽检履历")
Set wsData = Sheets("单板数整理")
' 获取日期范围
With wsBarrel
startDate = .Range("L2").value
endDate = .Range("P2").value
End With
' 构建机种件号字典
With wsData
For i = 2 To .Cells(.Rows.count, 1).End(xlUp).Row
dict(.Cells(i, 1).value & "|" & .Cells(i, 2).value) = .Cells(i, 3).value
Next
End With
' 主处理流程
With wsBarrel
lastRow = .Cells(.Rows.count, 2).End(xlUp).Row
For i = 4 To lastRow
On Error Resume Next
If IsDate(.Cells(i, 2).value) Then
If .Cells(i, 2).value >= startDate And .Cells(i, 2).value <= endDate Then
ProcessBarrelRow .Rows(i), dict, missingList, errorLog
End If
End If
Next
End With
' 输出结果
If Len(missingList) > 0 Then MsgBox "未匹配记录：" & vbCrLf & missingList
If Len(errorLog) > 0 Then MsgBox "处理错误：" & errorLog
MsgBox "镜片抽检数据处理完成！", vbInformation
End Sub
Private Sub ProcessBarrelRow(rng As Range, dict As Object, ByRef missList As String, ByRef errLog As String)
Dim key As String, numCount As Integer
On Error GoTo ErrorHandler
' 任务6：单板数匹配
key = rng.Cells(1, 7).value & "|" & rng.Cells(1, 8).value
If dict.exists(key) Then
rng.Cells(1, 11).value = dict(key)
Else
rng.Cells(1, 11).value = "请录入该机种单板数"
missList = missList & key & vbCrLf
End 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 With
Exit Sub
ErrorHandler:
errLog = errLog & "行" & rng.Row & "列" & Split(Err.Source, "$")(1) & "; "
End Sub
9.镜筒良率计算
Sub CalculateYieldAndAverage()
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim lastRow As Long, i As Long, j As Long, k As Long
Dim dictMachine As Object, arrMachines(), arrDates()
Dim arrResults(), totalCount As Long, rejectCount As Long
Dim targetDate As Date, currentMachine As String
Dim 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).Row
For i = 4 To lastRow
currentMachine = Trim(wsSource.Cells(i, "G").value)
If currentMachine <> "" And Not dictMachine.exists(currentMachine) Then
dictMachine.Add currentMachine, 1
End If
Next i
' 排序并输出机种到A列
arrMachines = dictMachine.keys
Call 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) + 1
For j = 1 To UBound(arrDates, 2)
targetDate = arrDates(1, j)
totalCount = 0
rejectCount = 0
' 统计符合条件的数据
For k = 4 To lastRow
If wsSource.Cells(k, "G").value = arrMachines(i - 1) And _
wsSource.Cells(k, "B").value = targetDate Then
totalCount = totalCount + 1
If wsSource.Cells(k, "O").value = "退" Then
rejectCount = rejectCount + 1
End If
End If
Next k
' 计算良率百分比
If totalCount > 0 Then
arrResults(i, j) = Round((totalCount - rejectCount) / totalCount, 4)
End If
Next j
Next 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) + 1
sumValues = 0
countValues = 0
For j = 1 To UBound(arrDates, 2)
If Not IsEmpty(arrResults(i, j)) Then
sumValues = sumValues + arrResults(i, j)
countValues = countValues + 1
End If
Next j
If countValues > 0 Then
wsTarget.Cells(2 + i, "B").value = Round(sumValues / countValues, 4)
End If
Next 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 Long
Dim temp As Variant
For i = LBound(arr) To UBound(arr) - 1
For j = i + 1 To UBound(arr)
If arr(i) > arr(j) Then
temp = arr(i)
arr(i) = arr(j)
arr(j) = temp
End If
Next j
Next i
End Sub
10.镜筒批退率
Sub CalculateYieldRate()
Dim wsData As Worksheet, wsReport As Worksheet
Dim startDate As Date, endDate As Date
Dim lastRow As Long, dict As Object
Dim arrData(), arrResult(), outputRow As Long
Dim i As Long, key As Variant, isSingleDate As Boolean
' 初始化设置
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
Set 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")) Then
MsgBox "请在AI2和AI4单元格输入有效日期", vbCritical
Exit Sub
End If
On Error Resume Next
startDate = CDate(wsReport.Range("AI2").value)
endDate = CDate(wsReport.Range("AI4").value)
If Err.Number <> 0 Then
MsgBox "日期格式不正确，请检查AI2和AI4单元格", vbCritical
Exit Sub
End If
On Error GoTo ErrorHandler
' 判断是单日期还是日期范围
isSingleDate = (DateDiff("d", startDate, endDate) = 0)
' 数据加载
lastRow = wsData.Cells(wsData.Rows.count, "B").End(xlUp).Row
If lastRow < 4 Then
MsgBox "抽检履历表无有效数据", vbExclamation
Exit Sub
End If
arrData = wsData.Range("B4:O" & lastRow).value
' 核心统计逻辑
For i = LBound(arrData) To UBound(arrData)
If IsDate(arrData(i, 1)) Then
Dim currentDate As Date
currentDate = CDate(arrData(i, 1))
' 检查日期是否符合条件
If (isSingleDate And DateValue(currentDate) = DateValue(startDate)) Or _
(Not isSingleDate And currentDate >= startDate And currentDate <= endDate) Then
Dim model As String
model = Trim(CStr(arrData(i, 6)))
' 跳过空机种
If model = "" Then GoTo NextItem
' 初始化字典项
If Not dict.exists(model) Then
dict.Add model, Array(0, 0) ' (总批次, 退批次)
End If
' 统计总数和退料数（不使用total = dict(key)(0)方式）
dict(model)(0) = dict(model)(0) + 1
If Trim(arrData(i, 14)) = "退" Then
dict(model)(1) = dict(model)(1) + 1
End If
End If
End If
NextItem:
Next i
' 结果输出
If dict.count > 0 Then
ReDim arrResult(1 To dict.count, 1 To 4)
outputRow = 1
' 使用字典键进行计数统计
For Each key In dict.keys
Dim total As Long, reject As Long
total = 0
reject = 0
' 重新计数（不使用dict(key)(0)方式）
For i = LBound(arrData) To UBound(arrData)
If IsDate(arrData(i, 1)) Then
currentDate = CDate(arrData(i, 1))
If (isSingleDate And DateValue(currentDate) = DateValue(startDate)) Or _
(Not isSingleDate And currentDate >= startDate And currentDate <= endDate) Then
If Trim(CStr(arrData(i, 6))) = key Then
total = total + 1
If Trim(arrData(i, 14)) = "退" Then
reject = reject + 1
End If
End If
End If
End If
Next i
arrResult(outputRow, 1) = key
arrResult(outputRow, 2) = total
arrResult(outputRow, 3) = reject
If total > 0 Then
arrResult(outputRow, 4) = reject / total
Else
arrResult(outputRow, 4) = 0
End If
outputRow = outputRow + 1
Next key
With 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:=xlNo
End If
End With
End If
Application.ScreenUpdating = True
MsgBox "处理完成！共统计 " & dict.count & " 个机种", vbInformation
Exit Sub
ErrorHandler:
Application.ScreenUpdating = True
MsgBox "错误 " & Err.Number & ": " & Err.Description, vbCritical
End Sub
二、反射率报表
1.机台通过率
Option Explicit
Sub AnalyzeMachinePassRate()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow1 As Long, lastRow2 As Long
Dim startDate As Date, endDate As Date
Dim dict As Object, key As String
Dim i As Long, j As Long, k As Long
Dim dateCol As Long
Dim a As Long, b As Long, c As Long, d As Long
Dim isLens As Boolean
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set ws1 = Worksheets("测试记录")
Set ws2 = Worksheets("机台分析")
Set dict = CreateObject("Scripting.Dictionary")
' 清除旧数据
ws2.Range("A3:AI1000").ClearContents
' 获取日期范围
startDate = ws2.Range("L1").Value
endDate = ws2.Range("P1").Value
' 判断分析模式
isLens = (ws2.Range("T1").Value = "镜片")
' 步骤1：提取不重复的机台
lastRow1 = ws1.Cells(ws1.Rows.count, "A").End(xlUp).Row
k = 3 ' 从第3行开始写入
For i = 3 To lastRow1
If 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) Then
key = ws1.Cells(i, 5).Value ' 机台
If Not dict.exists(key) Then
dict.Add key, k
ws2.Cells(k, 3).Value = key ' 机台
k = k + 1
End If
End If
End If
Next i
' 步骤2-9：计算各项指标
lastRow2 = ws2.Cells(ws2.Rows.count, "C").End(xlUp).Row
For i = 3 To lastRow2
' 初始化合计数据
c = 0
d = 0
' 遍历日期列
For dateCol = 5 To 35 ' E到AI列
If ws2.Cells(2, dateCol).Value >= startDate And ws2.Cells(2, dateCol).Value <= endDate Then
' 初始化每日数据
a = 0
b = 0
' 遍历测试记录
For j = 3 To lastRow1
If ws1.Cells(j, 1).Value = ws2.Cells(2, dateCol).Value Then
If ws1.Cells(j, 5).Value = ws2.Cells(i, 3).Value Then
' 步骤2/7：总测试数
a = a + 1
c = c + 1
' 步骤5/8：NG数
If ws1.Cells(j, 11).Value = "NG" Then
b = b + 1
d = d + 1
End If
End If
End If
Next j
' 步骤6：计算每日通过率
If a > 0 Then
ws2.Cells(i, dateCol).Value = Round((a - b) / a, 3)
ws2.Cells(i, dateCol).NumberFormat = "0.0%"
End If
End If
Next dateCol
' 步骤9：计算合计通过率
If c > 0 Then
ws2.Cells(i, 4).Value = Round((c - d) / c, 3)
ws2.Cells(i, 4).NumberFormat = "0.0%"
End If
Next 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
.Apply
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "机台通过率分析完成！当前模式：" & ws2.Range("T1").Value, vbInformation
End Sub
2.镜片通过率圈数分析
Option Explicit
Sub AnalyzeLensPassRate()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow1 As Long, lastRow2 As Long
Dim startDate As Date, endDate As Date
Dim dict As Object, key As String
Dim i As Long, j As Long, k As Long
Dim dateCol As Long
Dim a As Long, b As Long, c As Long, d As Long
Dim posCount As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set ws1 = Worksheets("测试记录")
Set ws2 = Worksheets("镜片通过率圈数分析")
Set dict = CreateObject("Scripting.Dictionary")
' 步骤0：清除旧数据
ws2.Range("A3:AL1000").ClearContents
' 获取日期范围
startDate = ws2.Range("L1").Value
endDate = ws2.Range("P1").Value
' 步骤1：提取不重复的机种和件号组合
lastRow1 = ws1.Cells(ws1.Rows.count, "A").End(xlUp).Row
k = 3 ' 从第3行开始写入
For i = 3 To lastRow1
If ws1.Cells(i, 1).Value >= startDate And ws1.Cells(i, 1).Value <= endDate Then
If ws1.Cells(i, 8).Value > 800 Then
key = ws1.Cells(i, 7).Value & "|" & ws1.Cells(i, 8).Value
If Not dict.exists(key) Then
dict.Add key, k
ws2.Cells(k, 2).Value = ws1.Cells(i, 7).Value ' 机种
ws2.Cells(k, 3).Value = ws1.Cells(i, 8).Value ' 件号
k = k + 1
End If
End If
End If
Next i
' 步骤2：填充客户工艺
lastRow2 = ws2.Cells(ws2.Rows.count, "B").End(xlUp).Row
For i = 3 To lastRow2
For j = 3 To lastRow1
If ws1.Cells(j, 1).Value >= startDate And ws1.Cells(j, 1).Value <= endDate Then
If ws1.Cells(j, 7).Value = ws2.Cells(i, 2).Value And _
ws1.Cells(j, 8).Value = ws2.Cells(i, 3).Value Then
ws2.Cells(i, 1).Value = ws1.Cells(j, 18).Value ' 客户工艺
Exit For
End If
End If
Next j
Next 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
.Apply
End With
' 步骤4-12：计算各项指标
For i = 3 To lastRow2
' 初始化合计数据
c = 0
d = 0
' 遍历日期列
For dateCol = 5 To 35 ' E到AI列
If ws2.Cells(2, dateCol).Value >= startDate And ws2.Cells(2, dateCol).Value <= endDate Then
' 初始化每日数据
a = 0
b = 0
' 遍历测试记录
For j = 3 To lastRow1
If ws1.Cells(j, 1).Value = ws2.Cells(2, dateCol).Value Then
If 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 + 3
c = c + 3
' 步骤5/8：NG数（按位置计数）
If ws1.Cells(j, 11).Value = "NG" Then
posCount = 0
If InStr(ws1.Cells(j, 14).Value, "上") > 0 Then posCount = posCount + 1
If InStr(ws1.Cells(j, 14).Value, "中") > 0 Then posCount = posCount + 1
If InStr(ws1.Cells(j, 14).Value, "下") > 0 Then posCount = posCount + 1
If InStr(ws1.Cells(j, 14).Value, "整罩") > 0 Then posCount = posCount + 3
b = b + posCount
d = d + posCount
' 步骤10-12：特定异常项目计数（含位置计数）
If InStr(ws1.Cells(j, 12).Value, "LAB") > 0 Then
ws2.Cells(i, 36).Value = ws2.Cells(i, 36).Value + posCount ' AJ列
End If
If InStr(ws1.Cells(j, 12).Value, "膜色") > 0 Then
ws2.Cells(i, 37).Value = ws2.Cells(i, 37).Value + posCount ' AK列
End If
If InStr(ws1.Cells(j, 12).Value, "反射率") > 0 Then
ws2.Cells(i, 38).Value = ws2.Cells(i, 38).Value + posCount ' AL列
End If
End If
End If
End If
Next j
' 步骤6：计算每日通过率
If a > 0 Then
ws2.Cells(i, dateCol).Value = Round((a - b) / a, 3)
ws2.Cells(i, dateCol).NumberFormat = "0.0%"
End If
End If
Next dateCol
' 步骤9：计算合计通过率
If c > 0 Then
ws2.Cells(i, 4).Value = Round((c - d) / c, 3)
ws2.Cells(i, 4).NumberFormat = "0.0%"
End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "镜片通过率圈数分析完成！", vbInformation
End Sub
3.镜片通过率罩次分析
Option Explicit
Sub AnalyzeLensPassRate()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow1 As Long, lastRow2 As Long
Dim startDate As Date, endDate As Date
Dim dict As Object, key As String
Dim i As Long, j As Long, k As Long
Dim dateCol As Long
Dim a As Long, b As Long, c As Long, d As Long
Dim upCount As Long, midCount As Long, downCount As Long, fullCount As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set ws1 = Worksheets("测试记录")
Set ws2 = Worksheets("镜片通过率罩次分析")
Set dict = CreateObject("Scripting.Dictionary")
' 清除旧数据
ws2.Range("A3:AP1000").ClearContents
' 获取日期范围
startDate = ws2.Range("L1").Value
endDate = ws2.Range("P1").Value
' 步骤1：提取不重复的机种和件号组合
lastRow1 = ws1.Cells(ws1.Rows.count, "A").End(xlUp).Row
k = 3 ' 从第3行开始写入
For i = 3 To lastRow1
If ws1.Cells(i, 1).Value >= startDate And ws1.Cells(i, 1).Value <= endDate Then
If ws1.Cells(i, 8).Value > 800 Then
key = ws1.Cells(i, 7).Value & "|" & ws1.Cells(i, 8).Value
If Not dict.exists(key) Then
dict.Add key, k
ws2.Cells(k, 2).Value = ws1.Cells(i, 7).Value ' 机种
ws2.Cells(k, 3).Value = ws1.Cells(i, 8).Value ' 件号
k = k + 1
End If
End If
End If
Next i
' 步骤2：填充客户工艺
lastRow2 = ws2.Cells(ws2.Rows.count, "B").End(xlUp).Row
For i = 3 To lastRow2
For j = 3 To lastRow1
If ws1.Cells(j, 1).Value >= startDate And ws1.Cells(j, 1).Value <= endDate Then
If ws1.Cells(j, 7).Value = ws2.Cells(i, 2).Value And _
ws1.Cells(j, 8).Value = ws2.Cells(i, 3).Value Then
ws2.Cells(i, 1).Value = ws1.Cells(j, 18).Value ' 客户工艺
Exit For
End If
End If
Next j
Next 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
.Apply
End With
' 步骤4-16：计算各项指标
For i = 3 To lastRow2
' 初始化合计数据
c = 0
d = 0
upCount = 0
midCount = 0
downCount = 0
fullCount = 0
' 遍历日期列
For dateCol = 5 To 35 ' E到AI列
If ws2.Cells(2, dateCol).Value >= startDate And ws2.Cells(2, dateCol).Value <= endDate Then
' 初始化每日数据
a = 0
b = 0
' 遍历测试记录
For j = 3 To lastRow1
If ws1.Cells(j, 1).Value = ws2.Cells(2, dateCol).Value Then
If 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 + 1
c = c + 1
' 步骤5/8：NG数
If ws1.Cells(j, 11).Value = "NG" Then
b = b + 1
d = d + 1
' 步骤10-12：特定异常项目计数
If InStr(ws1.Cells(j, 12).Value, "LAB") > 0 Then
ws2.Cells(i, 36).Value = ws2.Cells(i, 36).Value + 1 ' AJ列
End If
If InStr(ws1.Cells(j, 12).Value, "膜色") > 0 Then
ws2.Cells(i, 37).Value = ws2.Cells(i, 37).Value + 1 ' AK列
End If
If InStr(ws1.Cells(j, 12).Value, "反射率") > 0 Then
ws2.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 + 1
If InStr(ws1.Cells(j, 14).Value, "中") > 0 Then midCount = midCount + 1
If InStr(ws1.Cells(j, 14).Value, "下") > 0 Then downCount = downCount + 1
If InStr(ws1.Cells(j, 14).Value, "整罩") > 0 Then fullCount = fullCount + 1
End If
End If
End If
Next j
' 步骤6：计算每日通过率
If a > 0 Then
ws2.Cells(i, dateCol).Value = Round((a - b) / a, 3)
ws2.Cells(i, dateCol).NumberFormat = "0.0%"
End If
End If
Next dateCol
' 步骤9：计算合计通过率
If c > 0 Then
ws2.Cells(i, 4).Value = Round((c - d) / c, 3)
ws2.Cells(i, 4).NumberFormat = "0.0%"
End If
' 步骤13-16：计算位置比例
Dim total As Long
total = upCount + midCount + downCount + fullCount
If total > 0 Then
ws2.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 42
ws2.Cells(i, j).NumberFormat = "0.0%"
Next j
End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "分析完成!", vbInformation
End Sub
4.镜筒通过率圈数分析
Option Explicit
Sub AnalyzeLensPassRate()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow1 As Long, lastRow2 As Long
Dim startDate As Date, endDate As Date
Dim dict As Object, key As String
Dim i As Long, j As Long, k As Long
Dim dateCol As Long
Dim a As Long, b As Long, c As Long, d As Long
Dim posCount As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set ws1 = Worksheets("测试记录")
Set ws2 = Worksheets("镜筒通过率圈数分析")
Set dict = CreateObject("Scripting.Dictionary")
' 步骤0：清除旧数据
ws2.Range("A3:AL1000").ClearContents
' 获取日期范围
startDate = ws2.Range("L1").Value
endDate = ws2.Range("P1").Value
' 步骤1：提取不重复的机种和件号组合
lastRow1 = ws1.Cells(ws1.Rows.count, "A").End(xlUp).Row
k = 3 ' 从第3行开始写入
For i = 3 To lastRow1
If ws1.Cells(i, 1).Value >= startDate And ws1.Cells(i, 1).Value <= endDate Then
If ws1.Cells(i, 8).Value < 800 Then
key = ws1.Cells(i, 7).Value & "|" & ws1.Cells(i, 8).Value
If Not dict.exists(key) Then
dict.Add key, k
ws2.Cells(k, 2).Value = ws1.Cells(i, 7).Value ' 机种
ws2.Cells(k, 3).Value = ws1.Cells(i, 8).Value ' 件号
k = k + 1
End If
End If
End If
Next i
' 步骤2：填充客户工艺
lastRow2 = ws2.Cells(ws2.Rows.count, "B").End(xlUp).Row
For i = 3 To lastRow2
For j = 3 To lastRow1
If ws1.Cells(j, 1).Value >= startDate And ws1.Cells(j, 1).Value <= endDate Then
If ws1.Cells(j, 7).Value = ws2.Cells(i, 2).Value And _
ws1.Cells(j, 8).Value = ws2.Cells(i, 3).Value Then
ws2.Cells(i, 1).Value = ws1.Cells(j, 18).Value ' 客户工艺
Exit For
End If
End If
Next j
Next 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
.Apply
End With
' 步骤4-12：计算各项指标
For i = 3 To lastRow2
' 初始化合计数据
c = 0
d = 0
' 遍历日期列
For dateCol = 5 To 35 ' E到AI列
If ws2.Cells(2, dateCol).Value >= startDate And ws2.Cells(2, dateCol).Value <= endDate Then
' 初始化每日数据
a = 0
b = 0
' 遍历测试记录
For j = 3 To lastRow1
If ws1.Cells(j, 1).Value = ws2.Cells(2, dateCol).Value Then
If 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 + 3
c = c + 3
' 步骤5/8：NG数（按位置计数）
If ws1.Cells(j, 11).Value = "NG" Then
posCount = 0
If InStr(ws1.Cells(j, 14).Value, "上") > 0 Then posCount = posCount + 1
If InStr(ws1.Cells(j, 14).Value, "中") > 0 Then posCount = posCount + 1
If InStr(ws1.Cells(j, 14).Value, "下") > 0 Then posCount = posCount + 1
If InStr(ws1.Cells(j, 14).Value, "整罩") > 0 Then posCount = posCount + 3
b = b + posCount
d = d + posCount
' 步骤10-12：特定异常项目计数（含位置计数）
If InStr(ws1.Cells(j, 12).Value, "LAB") > 0 Then
ws2.Cells(i, 36).Value = ws2.Cells(i, 36).Value + posCount ' AJ列
End If
If InStr(ws1.Cells(j, 12).Value, "膜色") > 0 Then
ws2.Cells(i, 37).Value = ws2.Cells(i, 37).Value + posCount ' AK列
End If
If InStr(ws1.Cells(j, 12).Value, "反射率") > 0 Then
ws2.Cells(i, 38).Value = ws2.Cells(i, 38).Value + posCount ' AL列
End If
End If
End If
End If
Next j
' 步骤6：计算每日通过率
If a > 0 Then
ws2.Cells(i, dateCol).Value = Round((a - b) / a, 3)
ws2.Cells(i, dateCol).NumberFormat = "0.0%"
End If
End If
Next dateCol
' 步骤9：计算合计通过率
If c > 0 Then
ws2.Cells(i, 4).Value = Round((c - d) / c, 3)
ws2.Cells(i, 4).NumberFormat = "0.0%"
End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "镜筒通过率圈数分析完成！", vbInformation
End Sub
5.镜筒通过率罩次分析
Option Explicit
Sub AnalyzeLensPassRate()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow1 As Long, lastRow2 As Long
Dim startDate As Date, endDate As Date
Dim dict As Object, key As String
Dim i As Long, j As Long, k As Long
Dim dateCol As Long
Dim a As Long, b As Long, c As Long, d As Long
Dim upCount As Long, midCount As Long, downCount As Long, fullCount As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set ws1 = Worksheets("测试记录")
Set ws2 = Worksheets("镜筒通过率罩次分析")
Set dict = CreateObject("Scripting.Dictionary")
' 清除旧数据
ws2.Range("A3:AP1000").ClearContents
' 获取日期范围
startDate = ws2.Range("L1").Value
endDate = ws2.Range("P1").Value
' 步骤1：提取不重复的机种和件号组合
lastRow1 = ws1.Cells(ws1.Rows.count, "A").End(xlUp).Row
k = 3 ' 从第3行开始写入
For i = 3 To lastRow1
If ws1.Cells(i, 1).Value >= startDate And ws1.Cells(i, 1).Value <= endDate Then
If ws1.Cells(i, 8).Value < 800 Then
key = ws1.Cells(i, 7).Value & "|" & ws1.Cells(i, 8).Value
If Not dict.exists(key) Then
dict.Add key, k
ws2.Cells(k, 2).Value = ws1.Cells(i, 7).Value ' 机种
ws2.Cells(k, 3).Value = ws1.Cells(i, 8).Value ' 件号
k = k + 1
End If
End If
End If
Next i
' 步骤2：填充客户工艺
lastRow2 = ws2.Cells(ws2.Rows.count, "B").End(xlUp).Row
For i = 3 To lastRow2
For j = 3 To lastRow1
If ws1.Cells(j, 1).Value >= startDate And ws1.Cells(j, 1).Value <= endDate Then
If ws1.Cells(j, 7).Value = ws2.Cells(i, 2).Value And _
ws1.Cells(j, 8).Value = ws2.Cells(i, 3).Value Then
ws2.Cells(i, 1).Value = ws1.Cells(j, 18).Value ' 客户工艺
Exit For
End If
End If
Next j
Next 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
.Apply
End With
' 步骤4-16：计算各项指标
For i = 3 To lastRow2
' 初始化合计数据
c = 0
d = 0
upCount = 0
midCount = 0
downCount = 0
fullCount = 0
' 遍历日期列
For dateCol = 5 To 35 ' E到AI列
If ws2.Cells(2, dateCol).Value >= startDate And ws2.Cells(2, dateCol).Value <= endDate Then
' 初始化每日数据
a = 0
b = 0
' 遍历测试记录
For j = 3 To lastRow1
If ws1.Cells(j, 1).Value = ws2.Cells(2, dateCol).Value Then
If 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 + 1
c = c + 1
' 步骤5/8：NG数
If ws1.Cells(j, 11).Value = "NG" Then
b = b + 1
d = d + 1
' 步骤10-12：特定异常项目计数
If InStr(ws1.Cells(j, 12).Value, "LAB") > 0 Then
ws2.Cells(i, 36).Value = ws2.Cells(i, 36).Value + 1 ' AJ列
End If
If InStr(ws1.Cells(j, 12).Value, "膜色") > 0 Then
ws2.Cells(i, 37).Value = ws2.Cells(i, 37).Value + 1 ' AK列
End If
If InStr(ws1.Cells(j, 12).Value, "反射率") > 0 Then
ws2.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 + 1
If InStr(ws1.Cells(j, 14).Value, "中") > 0 Then midCount = midCount + 1
If InStr(ws1.Cells(j, 14).Value, "下") > 0 Then downCount = downCount + 1
If InStr(ws1.Cells(j, 14).Value, "整罩") > 0 Then fullCount = fullCount + 1
End If
End If
End If
Next j
' 步骤6：计算每日通过率
If a > 0 Then
ws2.Cells(i, dateCol).Value = Round((a - b) / a, 3)
ws2.Cells(i, dateCol).NumberFormat = "0.0%"
End If
End If
Next dateCol
' 步骤9：计算合计通过率
If c > 0 Then
ws2.Cells(i, 4).Value = Round((c - d) / c, 3)
ws2.Cells(i, 4).NumberFormat = "0.0%"
End If
' 步骤13-16：计算位置比例
Dim total As Long
total = upCount + midCount + downCount + fullCount
If total > 0 Then
ws2.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 42
ws2.Cells(i, j).NumberFormat = "0.0%"
Next j
End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "分析完成!", vbInformation
End Sub
6.客户工艺匹配
Sub MatchProcessAndClient()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow1 As Long, lastRow2 As Long
Dim dict As Object, key As String
Dim notFoundList As String
Dim i As Long
' 设置工作表对象
Set ws1 = Worksheets("测试记录")
Set ws2 = Worksheets("工艺&客户整理")
Set dict = CreateObject("Scripting.Dictionary")
' 构建机种件号字典
lastRow2 = ws2.Cells(ws2.Rows.count, "A").End(xlUp).Row
For i = 3 To lastRow2
key = ws2.Cells(i, 1).Value & "|" & ws2.Cells(i, 2).Value
If Not dict.exists(key) Then
dict.Add key, Array(ws2.Cells(i, 3).Value, ws2.Cells(i, 4).Value)
End If
Next i
' 匹配数据并填充
lastRow1 = ws1.Cells(ws1.Rows.count, "G").End(xlUp).Row
notFoundList = ""
For i = 3 To lastRow1
key = ws1.Cells(i, 7).Value & "|" & ws1.Cells(i, 8).Value
If 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 & vbCrLf
End If
Next i
' 显示未匹配项
If notFoundList <> "" Then
MsgBox "以下机种&件号未找到匹配项：" & vbCrLf & notFoundList, vbInformation, "匹配结果"
Else
MsgBox "所有机种&件号均匹配成功！", vbInformation, "匹配结果"
End If
End Sub
7.整体通过率
Sub CalculateTestStats()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow As Long, i As Long, j As Long
Dim dateRange As Range, cell As Range
Dim totalCount As Long, okCount As Long, ngCount As Long
Dim labCount As Long, colorCount As Long, reflectCount As Long
Dim posCount As Long, totalPosCount As Long
Dim 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").ClearContents
ws2.Range("D3:D16").ClearContents
ws2.Range("E19:AI32").ClearContents
ws2.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 Then
ws2.Cells(6, cell.Column).Value = Format(okCount / totalCount, "0.0%")
Else
ws2.Cells(6, cell.Column).Value = ""
End If
' 5. 统计各类异常
labCount = 0: colorCount = 0: reflectCount = 0
posCount = 0: totalPosCount = 0
labPosCount = 0: colorPosCount = 0: reflectPosCount = 0
For i = 3 To lastRow
If ws1.Cells(i, 1).Value = cell.Value Then
If ws1.Cells(i, 11).Value = "NG" Then
' 5.1 Lab异常
If InStr(1, ws1.Cells(i, 12).Value, "LAB") > 0 Then
labCount = labCount + 1
' 14. Lab异常且位置异常
posCount = GetPositionCount(ws1.Cells(i, 14).Value)
labPosCount = labPosCount + posCount
End If
' 5.2 膜色异常
If InStr(1, ws1.Cells(i, 12).Value, "膜色") > 0 Then
colorCount = colorCount + 1
' 15. 膜色异常且位置异常
posCount = GetPositionCount(ws1.Cells(i, 14).Value)
colorPosCount = colorPosCount + posCount
End If
' 5.3 反射率异常
If InStr(1, ws1.Cells(i, 12).Value, "反射率") > 0 Then
reflectCount = reflectCount + 1
' 16. 反射率异常且位置异常
posCount = GetPositionCount(ws1.Cells(i, 14).Value)
reflectPosCount = reflectPosCount + posCount
End If
' 12. 位置异常统计
posCount = GetPositionCount(ws1.Cells(i, 14).Value)
totalPosCount = totalPosCount + posCount
End If
End If
Next
' 输出各类异常统计结果
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. 总测试数×3
ws2.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 <> "" Then
ws2.Cells(13, cell.Column).Value = Format(ws2.Cells(11, cell.Column).Value / ws2.Cells(10, cell.Column).Value, "0.0%")
Else
ws2.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 Then
ws2.Range("D6").Value = Format(ws2.Range("D4").Value / ws2.Range("D3").Value, "0.0%")
Else
ws2.Range("D6").Value = ""
End If
ws2.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 = 0
For i = 3 To lastRow
If ws1.Cells(i, 11).Value = "NG" Then
totalPosCount = totalPosCount + GetPositionCount(ws1.Cells(i, 14).Value)
End If
Next
ws2.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 <> "" Then
ws2.Range("D13").Value = Format(ws2.Range("D11").Value / ws2.Range("D10").Value, "0.0%")
Else
ws2.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 = 0
For i = 3 To lastRow
If ws1.Cells(i, 1).Value = cell.Value And ws1.Cells(i, 8).Value < 800 Then
totalCount = totalCount + 1
End If
Next
ws2.Cells(19, cell.Column).Value = IIf(totalCount = 0, "", totalCount)
' 2. 统计OK批次(H列<800)
okCount = 0
For i = 3 To lastRow
If ws1.Cells(i, 1).Value = cell.Value And ws1.Cells(i, 8).Value < 800 And ws1.Cells(i, 11).Value = "OK" Then
okCount = okCount + 1
End If
Next
ws2.Cells(20, cell.Column).Value = IIf(okCount = 0, "", okCount)
' 3. 统计NG批次(H列<800)
ngCount = 0
For i = 3 To lastRow
If ws1.Cells(i, 1).Value = cell.Value And ws1.Cells(i, 8).Value < 800 And ws1.Cells(i, 11).Value = "NG" Then
ngCount = ngCount + 1
End If
Next
ws2.Cells(21, cell.Column).Value = IIf(ngCount = 0, "", ngCount)
' 4. 计算流通率
If totalCount > 0 And okCount > 0 Then
ws2.Cells(22, cell.Column).Value = Format(okCount / totalCount, "0.0%")
Else
ws2.Cells(22, cell.Column).Value = ""
End If
' 5. 统计各类异常(H列<800)
labCount = 0: colorCount = 0: reflectCount = 0
posCount = 0: totalPosCount = 0
For i = 3 To lastRow
If 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 Then
labCount = labCount + 1
End If
' 5.2 膜色异常
If InStr(1, ws1.Cells(i, 12).Value, "膜色") > 0 Then
colorCount = colorCount + 1
End If
' 5.3 反射率异常
If InStr(1, ws1.Cells(i, 12).Value, "反射率") > 0 Then
reflectCount = reflectCount + 1
End If
' 位置异常统计
posCount = GetPositionCount(ws1.Cells(i, 14).Value)
totalPosCount = totalPosCount + posCount
End If
Next
' 输出各类异常统计结果
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. 总测试数×3
ws2.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 <> "" Then
ws2.Cells(29, cell.Column).Value = Format(ws2.Cells(27, cell.Column).Value / ws2.Cells(26, cell.Column).Value, "0.0%")
Else
ws2.Cells(29, cell.Column).Value = ""
End If
' 10. 带位置信息的异常统计
'Dim labPosCount As Long, colorPosCount As Long, reflectPosCount As Long
labPosCount = 0: colorPosCount = 0: reflectPosCount = 0
For i = 3 To lastRow
If ws1.Cells(i, 1).Value = cell.Value And ws1.Cells(i, 8).Value < 800 And ws1.Cells(i, 11).Value = "NG" Then
posCount = GetPositionCount(ws1.Cells(i, 14).Value)
' 10.1 Lab异常+位置
If InStr(1, ws1.Cells(i, 12).Value, "LAB") > 0 And posCount > 0 Then
labPosCount = labPosCount + posCount
End If
' 10.2 膜色异常+位置
If InStr(1, ws1.Cells(i, 12).Value, "膜色") > 0 And posCount > 0 Then
colorPosCount = colorPosCount + posCount
End If
' 10.3 反射率异常+位置
If InStr(1, ws1.Cells(i, 12).Value, "反射率") > 0 And posCount > 0 Then
reflectPosCount = reflectPosCount + posCount
End If
End If
Next
ws2.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 Then
ws2.Range("D22").Value = Format(ws2.Range("D20").Value / ws2.Range("D19").Value, "0.0%")
Else
ws2.Range("D22").Value = ""
End If
ws2.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 = 0
For i = 3 To lastRow
If ws1.Cells(i, 8).Value < 800 And ws1.Cells(i, 11).Value = "NG" Then
totalPosCount = totalPosCount + GetPositionCount(ws1.Cells(i, 14).Value)
End If
Next
ws2.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 <> "" Then
ws2.Range("D29").Value = Format(ws2.Range("D27").Value / ws2.Range("D26").Value, "0.0%")
Else
ws2.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 Sub
Function GetPositionCount(posText As String) As Long
Dim count As Long
count = 0
If InStr(1, posText, "上") > 0 Then count = count + 1
If InStr(1, posText, "中") > 0 Then count = count + 1
If InStr(1, posText, "下") > 0 Then count = count + 1
If InStr(1, posText, "整罩") > 0 Then count = count + 3
GetPositionCount = count
End Function
总结
分享：
接受可以让我面对所有的问题，当我感到焦虑的时候，通常是因为我发现自己不能接受生活中的一些人、地方、事情，直到我完全接受了它们，我才能获得心灵上的安宁。除非我完全的接受生活，否则我将无法获得快乐。我不需要再纠结这个世界上有什么需要改变而是关注我自己的态度需要发生怎样的改变；