123
返回列表 上一主題 發帖

[發問] 如何利用VBA按鍵，來找出違反規則的號碼。

RCRG
　暱稱: RCRG滾奶滾企

中學生Rank: 2

帖子
95 
主題
24 
精華
0 
積分
118 
點名
0  
作業系統
XP 
軟體版本
Office 2003 
閱讀權限
20 
性別
男 
註冊時間
2015-11-10 
最後登錄
2020-5-25 
1# 跳轉到 » 正序看帖
打印
tT
發表於 2015-12-11 11:38 | 只看該作者

[發問] 如何利用VBA按鍵，來找出違反規則的號碼。

詳細問題內容       
規則1. 同樣的號碼中，在G欄相同的製造日期中，E欄的到期日也必須相同；       
規則2. 同樣的號碼中，當G欄的製造日期有多種時，則開始判斷 若G欄依先後排列後，是否 E欄的到期日也有依先後順序排列；       
若違反以上兩種規則任一，則視為異常號碼，將彈出視窗並顯示有哪些號碼違反。       
註：彈出視窗除了會指出錯誤的號碼外，如果能再顯示是哪一天的製造日有問題更好！       
       
詳細問題範例       
請見檔案內的 "範例說明頁"。       
       
        以上，問題求解，謝謝！也希望我竭盡所能的文意表達能讓各位大大看懂。XD

如何利用VBA按鍵，來找出違反規則號碼.rar (6.04 KB)

收藏 分享

RCRG
　暱稱: RCRG滾奶滾企

中學生Rank: 2

帖子
95 
主題
24 
精華
0 
積分
118 
點名
0  
作業系統
XP 
軟體版本
Office 2003 
閱讀權限
20 
性別
男 
註冊時間
2015-11-10 
最後登錄
2020-5-25 
23#
發表於 2015-12-24 05:21 | 只看該作者
回復 22# yen956


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

TOP

yen956

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

TOP

RCRG
　暱稱: RCRG滾奶滾企

中學生Rank: 2

帖子
95 
主題
24 
精華
0 
積分
118 
點名
0  
作業系統
XP 
軟體版本
Office 2003 
閱讀權限
20 
性別
男 
註冊時間
2015-11-10 
最後登錄
2020-5-25 
21#
發表於 2015-12-23 09:35 | 只看該作者
回復 20# yen956


To yen956大   
嚴重異常處理完，換 "嚴重異常2" 有問題了...XD，請參考下列檔案，3Q！
20151223_如何利用VBA按鍵，來找出違反規則號碼.rar (22.38 KB)

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
20#
發表於 2015-12-22 13:31 | 只看該作者
回復 19# RCRG
沒錯, 因錯誤訊息改放到處, 第11列忘了改, 將
    [J2:K65536] = ""
改成
    [H2:J65536] = ""
即可.

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

TOP

RCRG
　暱稱: RCRG滾奶滾企

中學生Rank: 2

帖子
95 
主題
24 
精華
0 
積分
118 
點名
0  
作業系統
XP 
軟體版本
Office 2003 
閱讀權限
20 
性別
男 
註冊時間
2015-11-10 
最後登錄
2020-5-25 
19#
發表於 2015-12-22 12:18 | 只看該作者
本帖最後由 RCRG 於 2015-12-22 12:27 編輯

回復 18# yen956


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

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

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
18#
發表於 2015-12-20 11:39 | 只看該作者
本帖最後由 yen956 於 2015-12-20 11:46 編輯

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

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
17#
發表於 2015-12-20 11:35 | 只看該作者
抱歉!!臨界值沒抓準, 已修改, 請再測試看看!!
  1. '插入序號, 以便恢復原狀
  2. Sub 插入序號(LstR As Integer)
  3.     Dim I As Integer
  4.     For I = 2 To LstR
  5.         Cells(I, 1) = I
  6.     Next
  7. End Sub
  8. Sub test()
  9.     Dim LstR As Integer, LstR2 As Integer, sR As Integer, I As Integer, cnt As Integer
  10.     Dim minDate As Date
  11.     [J2:K65536] = ""
  12.     '清除底色
  13.     [J:K].Interior.ColorIndex = xlNone
  14.     LstR2 = Cells(Rows.Count, 3).End(xlUp).Row
  15.     插入序號 LstR:=LstR2      '插入序號, 以便恢復原狀
  16.     [A1].Resize(LstR2, 10).Sort _
  17.             Key1:=[C1], Order1:=xlAscending, _
  18.             Key2:=[G1], Order1:=xlAscending, _
  19.             Header:=xlYes
  20.     LstR = Cells(Rows.Count, 3).End(xlUp).Row
  21.     sR = 1
  22.     Do
  23.         sR = sR + 1
  24.         If sR = 2 Then GoTo Next1:
  25.         cnt = sR
  26.         Do
  27.             '規則1.號碼相同且製造日相同, 但到期日不同
  28.             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
  29.                 Cells(sR - 1, 9) = "到期日異常1"
  30.                 Cells(sR - 1, 9).Interior.ColorIndex = 8
  31.                 Cells(sR, 9) = "到期日異常1"
  32.                 Cells(sR, 9).Interior.ColorIndex = 8
  33.             End If
  34.             sR = sR + 1
  35.         Loop Until Cells(sR, 3) <> Cells(sR - 1, 3) Or sR > LstR    '直到 號碼不同 或 資料結尾
  36.         '規則2. 到期日也必須排序
  37.         If sR - cnt <= 1 Then GoTo Next1:
  38.         For I = cnt To sR - 2
  39.             minDate = Application.Min(Cells(I + 1, 5).Resize(sR - I - 1, 1))
  40.             If Cells(I, 5) > minDate Then
  41.                 Cells(I, 10) = "到期日異常2"
  42.                 Cells(I, 10).Interior.ColorIndex = 38
  43.             End If
  44.         Next
  45. Next1:
  46.     Loop Until sR >= LstR  '直到資料結尾
  47.     '恢復原狀, 方便查核
  48.     [A1].Resize(LstR2, 10).Sort _
  49.             Key1:=[A1], Order1:=xlAscending, _
  50.             Header:=xlYes
  51. End Sub
複製代碼
p.s.
從 製造日 精準到"分鐘"看來, 製造日是由電腦自動輸出的,
但 到期日 為何不用 14# F 的建議, 改用公式自動輸入,
以減少人為 Key In 上的錯誤?
其實, 有違反規則1及規則2 的錯誤, 怎可能沒有 到期日<製造日 的人為 Key In 上的錯誤!?
test.gif

TOP

准提部林

帖子
2843 
主題
10 
精華
0 
積分
2899 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-5-31 
16#
發表於 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

TOP

RCRG
　暱稱: RCRG滾奶滾企

中學生Rank: 2

帖子
95 
主題
24 
精華
0 
積分
118 
點名
0  
作業系統
XP 
軟體版本
Office 2003 
閱讀權限
20 
性別
男 
註冊時間
2015-11-10 
最後登錄
2020-5-25 
15#
發表於 2015-12-20 08:55 | 只看該作者
本帖最後由 RCRG 於 2015-12-20 08:56 編輯

回復 14# yen956


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

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

20151220_如何利用VBA按鍵，來找出違反規則號碼.rar (17.49 KB)

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

TOP

        靜思自在 : 成功是優點的發揮，失敗是缺點的累積。
123
返回列表 上一主題