Sub romecyf()
Dim i, j, k, arr, brr, dic As Object
Set dic = CreateObject("scripting.dictionary")
Sheet2.Range("c5:m29").ClearContents
Sheet2.Range("c31:m55").ClearContents
Sheet2.Range("c57:m81").ClearContents
Row = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
arr = Sheet1.Range("a2:bv" & Row)
brr = Sheet2.Range("a3:m81")
satime = Sheet2.Range("e2")
edtime = Sheet2.Range("j2")
hhhh = edtime + 1
For i = 3 To UBound(arr)
If arr(i, 70) <> "" Then
发现时间 = DateValue(Split(arr(i, 70), " ")(0))
Else
发现时间 = DateValue(Split(arr(i, 27), " ")(0))
End If
If arr(i, 72) <> "" Then
消缺时间 = DateValue(Split(arr(i, 72), " ")(0))
Else
If arr(i, 37) = "" Then
消缺时间 = DateValue("2525-12-30")
Else
消缺时间 = DateValue(Split(arr(i, 37), " ")(0))
End If
End If
If arr(i, 73) = "" Then
终止时间 = DateValue("2525-12-30")
Else
终止时间 = DateValue(Split(arr(i, 73), " ")(0))
End If
If 发现时间 < satime And 消缺时间 >= satime And edtime <= 终止时间 Then
aa = "遗留本期缺陷" & arr(i, 2) & arr(i, 5) & arr(i, 10)
bb = "遗留本期合计" & arr(i, 2)
dic(aa) = dic(aa) + 1
dic(bb) = dic(bb) + 1
End If
If 发现时间 >= satime And 发现时间 < edtime + 1 And edtime <= 终止时间 Then
aa = "本期新增缺陷" & arr(i, 2) & arr(i, 5) & arr(i, 10)
bb = "本期新增合计" & arr(i, 2)
dic(aa) = dic(aa) + 1
dic(bb) = dic(bb) + 1
End If
If 消缺时间 >= satime And 消缺时间 < edtime + 1 And edtime <= 终止时间 Then
aa = "本期消缺缺陷" & arr(i, 2) & arr(i, 5) & arr(i, 10)
bb = "本期消缺合计" & arr(i, 2)
dic(aa) = dic(aa) + 1
dic(bb) = dic(bb) + 1
End If
Next i
For i = 2 To UBound(brr)
If InStr(brr(i, 1), "缺陷") Then st = brr(i, 1): GoTo 99
If InStr(brr(i, 1), "合计") Then
For j = 3 To UBound(brr, 2)
brr(i, j) = dic(brr(i, 1) & brr(1, j))
Next j
GoTo 99
End If
For j = 3 To UBound(brr, 2)
aa = st & brr(1, j) & brr(i, 2) & brr(i, 1)
If dic.exists(aa) Then brr(i, j) = dic(aa)
Next j
99
Next i
Sheet2.Range("a3").Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub
