麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 如何利用VBA按鍵，來找出違反規則的號碼。 [打印本頁]

作者: RCRG 時間: 2015-12-11 11:38 標題: 如何利用VBA按鍵，來找出違反規則的號碼。

詳細問題內容
規則1. 同樣的號碼中，在G欄相同的製造日期中，E欄的到期日也必須相同；
規則2. 同樣的號碼中，當G欄的製造日期有多種時，則開始判斷若G欄依先後排列後，是否 E欄的到期日也有依先後順序排列；
若違反以上兩種規則任一，則視為異常號碼，將彈出視窗並顯示有哪些號碼違反。
註：彈出視窗除了會指出錯誤的號碼外，如果能再顯示是哪一天的製造日有問題更好！

詳細問題範例
請見檔案內的 "範例說明頁"。

以上，問題求解，謝謝！也希望我竭盡所能的文意表達能讓各位大大看懂。XD

[attach]22790[/attach]

[attach]22792[/attach]

作者: RCRG 時間: 2015-12-11 12:22

詳細問題內容
規則1. 同樣的號碼中，在G欄相同的製造日期中，E欄的到期日也必須相同；
規則2. 同樣的號 ...
RCRG 發表於 2015-12-11 11:38

下半部E欄的到期日忘記上區塊顏色了....XD

作者: 准提部林 時間: 2015-12-12 12:52

在Ｈ欄列出錯誤訊息，
用MSGBOX串出一大堆，關閉後忘光光，用處不大！！！

Sub 檢測()
Dim xD, xD1, R&, T$, TM1&, TM2&, i&
R = [C65536].End(xlUp).Row
[H:H].ClearContents
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
For i = 2 To R
　　T = Range("C" & i): TM1 = Int(Range("E" & i)): TM2 = Int(Range("G" & i))
　　If T = "" Or TM1 = 0 Or TM2 = 0 Then GoTo 101
　　If TM1 < xD(T) Then xD1(T & TM1) = "到期日未排序": GoTo 101
　　xD(T) = TM1
　　If xD(T & TM2) = 0 Then xD(T & TM2) = TM1
　　If xD(T & TM2) <> TM1 Then xD1(T & TM2) = "到期日異常": GoTo 101
101: Next
　
For i = 2 To R
　　T = Range("C" & i): TM1 = Int(Range("E" & i)): TM2 = Int(Range("G" & i))
　　If xD1(T & TM1) <> "" Then Range("H" & i) = xD1(T & TM1)
　　If xD1(T & TM2) <> "" Then Range("H" & i) = xD1(T & TM2)
102: Next
End Sub

〔製造日〕必須先排序，同編號的〔到期日〕比上面的小，就算異常！！

作者: RCRG 時間: 2015-12-12 14:15

回復 3# 准提部林

准大考量的是，的確在H欄直接出現提示比較方便，程式要幾天後才能測試，先謝謝准大了！

作者: yen956 時間: 2015-12-13 15:23

本帖最後由 yen956 於 2015-12-13 15:26 編輯

如圖:
[attach]22818[/attach]
1.原資料有多筆到期日<製造日?
是否要增加此判斷?
2. 規則2 有存在的入要嗎?

作者: yen956 時間: 2015-12-13 15:42

試試看:

'插入序號, 以便恢復原狀
Sub 插入序號(LstR As Integer)
Dim i As Integer
For i = 2 To LstR
Cells(i, 1) = i
Next
End Sub
Sub test()
Dim LstR As Integer, LstR2 As Integer, sR As Integer
Dim mDate1 As Date, mDate2 As Date
[H2:J65536] = ""
'清除底色, 如你原有底色的需求, 請將下列去除
[C:I].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, _
Key3:=[E1], Order1:=xlAscending, _
Header:=xlYes
LstR = Cells(Rows.Count, 3).End(xlUp).Row
sR = 2
mDate1 = DateSerial(Year(Cells(sR, 7)), Month(Cells(sR, 7)), Day(Cells(sR, 7)))
Do
'新增異常紀錄,如無此需求,請去除
If Cells(sR, 5) < mDate1 Then '到期日<製造日
Cells(sR, 8) = "到期日<製造日"
'加入底色, 如你原有底色的需求, 請將下兩列去除
Cells(sR, 8).Interior.ColorIndex = 38
Cells(sR, 3).Resize(1, 5).Interior.ColorIndex = 38
End If
If sR = 2 Then GoTo Next1:
' '號碼相同,到期日未排序(規則2 似乎沒有存在的必要, 故去除)
' If Cells(sR, 3) = Cells(sR - 1, 3) And Cells(sR, 5) < Cells(sR - 1, 5) Then
' Cells(sR, 10) = "到期日未排序"
' '加入底色, 如你原有底色的需求, 請將下列去除
' Cells(sR, 3).Resize(1, 5).Interior.ColorIndex = 6
' End If
'製造日相同, 但到期日不同
If mDate1 = mDate2 And Cells(sR, 5) <> Cells(sR - 1, 5) Then
Cells(sR - 1, 9) = "到期日異常"
'加入底色, 如你原有底色的需求, 請將下兩列去除
Cells(sR - 1, 9).Interior.ColorIndex = 8
Cells(sR - 1, 3).Resize(1, 5).Interior.ColorIndex = 8
Cells(sR, 9) = "到期日異常"
'加入底色, 如你原有底色的需求, 請將下兩列去除
Cells(sR, 9).Interior.ColorIndex = 8
Cells(sR, 3).Resize(1, 5).Interior.ColorIndex = 8
End If
Next1:
sR = sR + 1
mDate1 = DateSerial(Year(Cells(sR - 1, 7)), Month(Cells(sR - 1, 7)), Day(Cells(sR - 1, 7)))
mDate2 = DateSerial(Year(Cells(sR, 7)), Month(Cells(sR, 7)), Day(Cells(sR, 7)))
Loop Until sR > LstR
'恢復原狀, 方便查核
[A1].Resize(LstR2, 9).Sort _
Key1:=[A1], Order1:=xlAscending, _
Header:=xlYes
End Sub

複製代碼

作者: RCRG 時間: 2015-12-14 09:52

回復 5# yen956

1.原資料有多筆到期日<製造日? 是否要增加此判斷?
實際上是不會發生 "到期日<製造日" 的，恕我沒檢查到這著個舉例疏失，造成誤會，SOR！QQ

2. 規則2 有存在的入要嗎?

規則2有存在必要唷！甚至對我來說比規則1還重要，因為原則上製造日早的應該要先到期，而規則2就是在檢查這個環節！

作者: yen956 時間: 2015-12-14 14:11

針對規則2 修正:
試試看:

'插入序號, 以便恢復原狀
Sub 插入序號(LstR As Integer)
Dim I As Integer
For I = 2 To LstR
Cells(I, 1) = I
Next
End Sub
Sub test()
Dim LstR As Integer, LstR2 As Integer, sR As Integer, I As Integer, cnt As Integer
Dim minDate As Date
[H2:J65536] = ""
'清除底色, 如你原有底色的需求, 請將下列去除
[C:I].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 = 1
Do
cnt = sR
Do
sR = sR + 1
If sR = 2 Then GoTo Next1:
'規則1.製造日相同, 但到期日不同
If Int(Cells(sR, 7)) = Int(Cells(sR - 1, 7)) And Cells(sR, 5) <> Cells(sR - 1, 5) Then
Cells(sR - 1, 8) = "到期日異常1"
'加入底色, 如你原有底色的需求, 請將下兩列去除
Cells(sR - 1, 8).Interior.ColorIndex = 8
Cells(sR - 1, 3).Resize(1, 5).Interior.ColorIndex = 8
Cells(sR, 8) = "到期日異常1"
'加入底色, 如你原有底色的需求, 請將下兩列去除
Cells(sR, 8).Interior.ColorIndex = 8
Cells(sR, 3).Resize(1, 5).Interior.ColorIndex = 8
End If
Loop Until Cells(sR, 3) <> Cells(sR - 1, 3) Or sR > LstR '直到號碼不同或資料結尾
'規則2. 到期日也必須排序
If sR - cnt <= 1 Then GoTo Next1:
For I = cnt To sR - 2
minDate = Application.Min(Cells(I + 1, 5).Resize(sR - I - 1, 1))
If Cells(I, 5) > minDate Then
Cells(I, 9) = "到期日異常2"
'加入底色, 如你原有底色的需求, 請將下兩列去除
Cells(I, 9).Interior.ColorIndex = 38
Cells(I, 3).Resize(1, 5).Interior.ColorIndex = 38
End If
Next
Next1:
Loop Until sR > LstR '直到資料結尾
'恢復原狀, 方便查核
[A1].Resize(LstR2, 9).Sort _
Key1:=[A1], Order1:=xlAscending, _
Header:=xlYes
End Sub

複製代碼

執行結果如下圖:
[attach]22831[/attach]

作者: RCRG 時間: 2015-12-18 14:55

回復 8# yen956

謝謝yen大的解答，不過I24似乎不該出現"到期日異常2"，查看一下原因似乎yen大把製造日的"時間"也比對進去了！製造日只需比對"日期"，後面時間可以忽略；
另外A欄的序號用意是？這是一定都會出現嗎?

作者: yen956 時間: 2015-12-19 04:56

Q2:另外A欄的序號用意是？這是一定都會出現嗎?
VBA52列不是說的很清嗎?
如無此需求, 則相關VBACode去悼即可.
Q1:這不是你自己訂的規則2.嗎?如下圖:
[attach]22873[/attach]

作者: yen956 時間: 2015-12-19 09:02

本帖最後由 yen956 於 2015-12-19 09:07 編輯

補充說明:
1. 不加入序號可不可以?
插入序號, 以便恢復原狀,
除錯的目的不是打亂原表格,
因原VBA利用Excel 的排序功能,
[A1].Resize(LstR2, 10).Sort _
         Key1:=[C1], Order1:=xlAscending, _
         Key2:=[G1], Order1:=xlAscending, _
         Header:=xlYes
會打亂原表格, 故排序前先加入序號.
如欄A有重要資料可移到他處, 如欄K
若移到欄K,[K1]可鍵入"序號", 原VBA可改成
[A1].Resize(LstR2, 11).Sort _
         Key1:=[C1], Order1:=xlAscending, _
         Key2:=[G1], Order1:=xlAscending, _
         Header:=xlYes
及將
'插入序號, 以便恢復原狀
Sub 插入序號(LstR As Integer)
Dim I As Integer
For I = 2 To LstR
      Cells(I, 1) = I
Next
End Sub
改成
For I = 2 To LstR
      Cells(I, 11) = I
Next
及將
'恢復原狀, 方便查核
[A1].Resize(LstR2, 9).Sort _
         Key1:=[A1], Order1:=xlAscending, _
         Header:=xlYes
改成
[A1].Resize(LstR2, 11).Sort _
         Key1:=[k1], Order1:=xlAscending, _
         Header:=xlYes
最後加入
[K1:K65536] = ""
予以清除.

作者: yen956 時間: 2015-12-19 09:29

本帖最後由 yen956 於 2015-12-19 09:34 編輯

回復 9# RCRG
"不過I24似乎不該出現"到期日異常2"，查看一下原因似乎yen大把製造日的"時間"也比對進去了！製造日只需比對"日期"，後面時間可以忽略"
反正 "製造日" 相同, "到期日" 不同, 就一定會違反 "規則1",
此時要不要 "把製造日的"時間"也比對進去" 就無關緊要了,
這種情形的違反 "規則2" 必違反 "規則1",
因利用Excel本身的排序功能,
[A1].Resize(LstR2, 11).Sort _
         Key1:=[C1], Order1:=xlAscending, _
         Key2:=[G1], Order1:=xlAscending, _
         Header:=xlYes
很難避開時間的問題(除非另加補助欄, 先把欄G用公式 =int(G2) 全部去掉時間, 改成日期).

作者: RCRG 時間: 2015-12-19 11:19

本帖最後由 RCRG 於 2015-12-19 11:21 編輯

回復 3# 准提部林

回復 12# yen956

謝謝兩位熱心又專業的解答，今天至公司實際測試心得如下：

[attach]22880[/attach]
如上面檔案，再舉個範例8，准大的呈現方式不知能否只在60和61列顯示異常，這樣我比較不會眼花撩亂XD。

兩位大大不知能否幫我加幾項修改
1. 顯示異常的欄位改到A欄和B欄，如下圖1
2. 沒資料或貼上資料不符合型式者，彈出視窗說明(因為我亂填資料會出現錯誤視窗，如下圖2)

圖1
[attach]22881[/attach]

圖2
[attach]22882[/attach]

其他大致應該就沒甚麼問題了，再次謝謝兩位大大！

作者: yen956 時間: 2015-12-19 13:55

建議:
1. 另新增一工作表, 內只有號碼、品名(方便輸入有效期限)、有效期限三欄
2. 號碼是唯一的, 且須由小到大排列(EXCEL 2003必須, 以後版本不清楚), 有效期限以天為單位.
利用進階篩選, 不選重覆, 即可得號碼是唯一的, 操作如下圖:
[attach]22883[/attach]
3. 填入有效期限(單位:天), 即三個月應輸入90,
4. 回到主頁(範例說明頁),在 E2 輸入公式, 向下拉
=IF(C2="","",INT(G2)+LOOKUP(C2,Sheet3!A:A,Sheet3!C:C))
(Sheet3 是工作表名稱)
大功告成, 如此保証 "到期日" 絶對不會出錯!!

作者: RCRG 時間: 2015-12-20 08:55

本帖最後由 RCRG 於 2015-12-20 08:56 編輯

回復 14# yen956

請教一下yen956大，我發現了一個嚴重的問題，

不該出現異常的竟然跑出一堆異常，因為竟然會去比對不同號碼(正常應該是同號碼下去比較)
，倒是用准大版本的卻沒有這個問題，有勞yen956大幫我看一下好嗎? 謝謝！

[attach]22889[/attach]

問題檔案如上，可以的話修改VBA後，再幫我全部重PO一次讓我抓取好嗎? 再次謝謝了！

作者: 准提部林 時間: 2015-12-20 11:01

本帖最後由准提部林於 2015-12-20 11:03 編輯

Sub 檢測1()
Dim xD, xD1, R&, T$, TM1, TM2, i&, TT$
R = [C65536].End(xlUp).Row
[A:B].ClearContents
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
For i = 2 To R
　　T = Range("C" & i): TM1 = Range("E" & i): TM2 = Range("G" & i)
　　If T = "" Or IsDate(TM1) = 0 Or IsDate(TM2) = 0 Then GoTo 101
　
　　TM1 = Int(TM1): TM2 = Int(TM2)
　　If TM1 < xD(T) Then xD1(T & TM1) = "2.到期日未排序"
　　xD(T) = TM1
　
　　If xD(T & TM2) = 0 Then xD(T & TM2) = TM1
　　If xD(T & TM2) <> TM1 Then xD1(T & TM2) = "1.到期日異常": GoTo 101
101: Next
　
For i = 2 To R
　　TT = ""
　　T = Range("C" & i): TM1 = Range("E" & i): TM2 = Range("G" & i)
　　If T = "" And TM1 = "" And TM2 = "" Then GoTo 102
　
　　If T = "" Then TT = "／1.號碼"
　　If Not IsDate(TM1) Then TT = TT & "" & "／2.到期日"
　　If Not IsDate(TM2) Then TT = TT & "／3.製造日"
　　If TT <> "" Then Range("B" & i) = "*請檢查_" & Mid(TT, 2) & "": GoTo 102
　
　　TM1 = Int(TM1): TM2 = Int(TM2)
　　If xD1(T & TM1) <> "" Then Range("A" & i) = xD1(T & TM1)
　　If xD1(T & TM2) <> "" Then Range("A" & i) = xD1(T & TM2)
102: Next
End Sub

作者: yen956 時間: 2015-12-20 11:35

抱歉!!臨界值沒抓準, 已修改, 請再測試看看!!

'插入序號, 以便恢復原狀
Sub 插入序號(LstR As Integer)
Dim I As Integer
For I = 2 To LstR
Cells(I, 1) = I
Next
End Sub
Sub test()
Dim LstR As Integer, LstR2 As Integer, sR As Integer, I As Integer, cnt As Integer
Dim minDate As Date
[J2:K65536] = ""
'清除底色
[J:K].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 = 1
Do
sR = sR + 1
If sR = 2 Then GoTo Next1:
cnt = sR
Do
'規則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 - 1, 9) = "到期日異常1"
Cells(sR - 1, 9).Interior.ColorIndex = 8
Cells(sR, 9) = "到期日異常1"
Cells(sR, 9).Interior.ColorIndex = 8
End If
sR = sR + 1
Loop Until Cells(sR, 3) <> Cells(sR - 1, 3) Or sR > LstR '直到號碼不同或資料結尾
'規則2. 到期日也必須排序
If sR - cnt <= 1 Then GoTo Next1:
For I = cnt To sR - 2
minDate = Application.Min(Cells(I + 1, 5).Resize(sR - I - 1, 1))
If Cells(I, 5) > minDate Then
Cells(I, 10) = "到期日異常2"
Cells(I, 10).Interior.ColorIndex = 38
End If
Next
Next1:
Loop Until sR >= LstR '直到資料結尾
'恢復原狀, 方便查核
[A1].Resize(LstR2, 10).Sort _
Key1:=[A1], Order1:=xlAscending, _
Header:=xlYes
End Sub

複製代碼

p.s.
從製造日精準到"分鐘"看來, 製造日是由電腦自動輸出的,
但到期日為何不用 14# F 的建議, 改用公式自動輸入,
以減少人為 Key In 上的錯誤?
其實, 有違反規則1及規則2 的錯誤, 怎可能沒有到期日<製造日的人為 Key In 上的錯誤!?
[attach]22892[/attach]

作者: yen956 時間: 2015-12-20 11:39

本帖最後由 yen956 於 2015-12-20 11:46 編輯

回復 16# 准提部林
大大抱歉!!來不及用大大新版測試就上傳!!

作者: RCRG 時間: 2015-12-22 12:18

本帖最後由 RCRG 於 2015-12-22 12:27 編輯

回復 18# yen956

感謝yen956大修改解答，不過修改完反而變成，如果把日期改為正確，好像也不會把原本的 "異常1&2" 字眼清除了呢！

關於"以減少人為 Key In 上的錯誤?"，其實整篇資料都會是用複製過來的，原則上不會有誤KEY，有誤會的地方應該是我自己檔案舉例不好，但還是先謝謝Y大提醒唷！

作者: yen956 時間: 2015-12-22 13:31

回復 19# RCRG
沒錯, 因錯誤訊息改放到處, 第11列忘了改, 將
[J2:K65536] = ""
改成
[H2:J65536] = ""
即可.

p.s.
"其實整篇資料都會是用複製過來的，原則上不會有誤KEY"
那就是原稿就錯?!別的單位送過來的?那又何必除錯?

作者: RCRG 時間: 2015-12-23 09:35

回復 20# yen956

To yen956大
嚴重異常處理完，換 "嚴重異常2" 有問題了...XD，請參考下列檔案，3Q！
[attach]22932[/attach]

作者: yen956 時間: 2015-12-23 14:03

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

複製代碼

作者: RCRG 時間: 2015-12-24 05:21

回復 22# yen956

感謝yen956大再度幫忙修改，目前測試手邊的資料是完全沒問題的；
我不太懂VBA邏輯，所以不知道為什麼照著異常1和異常2的原則走，卻還是有些資料還會有問題(如先前的嚴重錯誤1和2)，
所以不知道有沒有可能下次的資料又會有不同的新問題，是有點擔心啦！不過現況有幫我解決到了就好，還是很感謝yen956大，當然還有准大，兩種版本我都喜歡，所以這是我首次一次採用兩版本；
最後，再次謝謝兩位多次修改與幫忙！3Q

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)