- 帖子
- 522
- 主題
- 36
- 精華
- 1
- 積分
- 603
- 點名
- 0
- 作業系統
- win xp sp3
- 軟體版本
- Office 2003
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2012-12-13
- 最後登錄
- 2021-7-11
|
回復 21# RCRG
感謝謝再三測試,造成不便, 還請包涵!!
這個版本, 輸出位置故意與准大錯開, 方便你比對.
試試看:- '插入序號, 以便恢復原狀
- Sub 插入序號(LstR As Integer)
- Dim I As Integer
- For I = 2 To LstR
- Cells(I, 10) = I
- Next
- End Sub
- Sub test()
- Dim LstR As Integer, LstR2 As Integer, sR As Integer, I As Integer, cnt As Integer
- Dim maxDate As Date
- Sheets("嚴重錯誤").Select
- [H2:J65536] = ""
- [H:J].Interior.ColorIndex = xlNone '清除底色
- LstR2 = Cells(Rows.Count, 3).End(xlUp).Row
- 插入序號 LstR:=LstR2 '插入序號, 以便恢復原狀
- [A1].Resize(LstR2, 10).Sort _
- Key1:=[C1], Order1:=xlAscending, _
- Key2:=[G1], Order1:=xlAscending, _
- Header:=xlYes
- LstR = Cells(Rows.Count, 3).End(xlUp).Row
- sR = 2
- Do
- cnt = sR
- Do
- '規則2.號碼相同, 且製造日有排序, 則到期日也必須排序
- If Cells(sR, 3) = Cells(sR + 1, 3) And Cells(sR, 5) > Cells(sR + 1, 5) Then
- Cells(sR, 9) = "異常2a"
- Cells(sR, 9).Interior.ColorIndex = 38
- End If
- '規則1.號碼相同, 且製造日相同, 但到期日不同
- If Cells(sR, 3) = Cells(sR + 1, 3) And Int(Cells(sR, 7)) = Int(Cells(sR + 1, 7)) And Cells(sR, 5) <> Cells(sR + 1, 5) Then
- Cells(sR, 8) = "異常1"
- Cells(sR, 8).Interior.ColorIndex = 8
- Cells(sR + 1, 8) = "異常1"
- Cells(sR + 1, 8).Interior.ColorIndex = 8
- End If
- sR = sR + 1
- Loop Until Cells(sR, 3) <> Cells(sR + 1, 3) Or sR >= LstR '直到 號碼不同 或 資料結尾
- For I = cnt To sR
- maxDate = Application.Max(Cells(I, 5).Resize(sR - 1, 1))
- '規則2.號碼相同, 且製造日有排序, 則到期日也必須排序
- If Cells(I, 3) = Cells(I + 1, 3) And Cells(I, 5) > maxDate Then
- Cells(I, 9) = "異常2b"
- Cells(I, 9).Interior.ColorIndex = 38
- End If
- Next
- Loop Until sR >= LstR '直到資料結尾
- '恢復原狀
- [A1].Resize(LstR2, 10).Sort _
- Key1:=[J1], Order1:=xlAscending, _
- Header:=xlYes
- End Sub
|
|
發表於 2015-12-23 14:03
| 