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 
2#
發表於 2015-12-11 12:22 | 只看該作者
詳細問題內容       
規則1. 同樣的號碼中，在G欄相同的製造日期中，E欄的到期日也必須相同；       
規則2. 同樣的號 ...
RCRG 發表於 2015-12-11 11:38



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

TOP

准提部林

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


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

TOP

RCRG
　暱稱: RCRG滾奶滾企

中學生Rank: 2

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


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

TOP

yen956

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

如圖:

1.原資料有多筆 到期日<製造日?
是否要增加此判斷?
2. 規則2 有存在的入要嗎?

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
6#
發表於 2015-12-13 15:42 | 只看該作者
試試看:
  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

  9. Sub test()
  10.     Dim LstR As Integer, LstR2 As Integer, sR As Integer
  11.     Dim mDate1 As Date, mDate2 As Date
  12.     [H2:J65536] = ""
  13.     '清除底色, 如你原有底色的需求, 請將下列去除
  14.     [C:I].Interior.ColorIndex = xlNone
  15.     LstR2 = Cells(Rows.Count, 3).End(xlUp).Row
  16.     插入序號 LstR:=LstR2      '插入序號, 以便恢復原狀
  17.     [A1].Resize(LstR2, 10).Sort _
  18.             Key1:=[C1], Order1:=xlAscending, _
  19.             Key2:=[G1], Order1:=xlAscending, _
  20.             Key3:=[E1], Order1:=xlAscending, _
  21.             Header:=xlYes
  22.     LstR = Cells(Rows.Count, 3).End(xlUp).Row
  23.     sR = 2
  24.     mDate1 = DateSerial(Year(Cells(sR, 7)), Month(Cells(sR, 7)), Day(Cells(sR, 7)))
  25.     Do
  26.         '新增異常紀錄,如無此需求,請去除
  27.         If Cells(sR, 5) < mDate1 Then    '到期日<製造日
  28.             Cells(sR, 8) = "到期日<製造日"
  29.            '加入底色, 如你原有底色的需求, 請將下兩列去除
  30.             Cells(sR, 8).Interior.ColorIndex = 38
  31.             Cells(sR, 3).Resize(1, 5).Interior.ColorIndex = 38
  32.         End If
  33.         
  34.         If sR = 2 Then GoTo Next1:
  35. '        '號碼相同,到期日未排序(規則2 似乎沒有存在的必要, 故去除)
  36. '        If Cells(sR, 3) = Cells(sR - 1, 3) And Cells(sR, 5) < Cells(sR - 1, 5) Then
  37. '            Cells(sR, 10) = "到期日未排序"
  38. '           '加入底色, 如你原有底色的需求, 請將下列去除
  39. '            Cells(sR, 3).Resize(1, 5).Interior.ColorIndex = 6
  40. '        End If
  41.         
  42.         '製造日相同, 但到期日不同
  43.         If mDate1 = mDate2 And Cells(sR, 5) <> Cells(sR - 1, 5) Then
  44.             Cells(sR - 1, 9) = "到期日異常"
  45.            '加入底色, 如你原有底色的需求, 請將下兩列去除
  46.             Cells(sR - 1, 9).Interior.ColorIndex = 8
  47.             Cells(sR - 1, 3).Resize(1, 5).Interior.ColorIndex = 8
  48.             Cells(sR, 9) = "到期日異常"
  49.            '加入底色, 如你原有底色的需求, 請將下兩列去除
  50.             Cells(sR, 9).Interior.ColorIndex = 8
  51.             Cells(sR, 3).Resize(1, 5).Interior.ColorIndex = 8
  52.         End If
  53. Next1:
  54.         sR = sR + 1
  55.         mDate1 = DateSerial(Year(Cells(sR - 1, 7)), Month(Cells(sR - 1, 7)), Day(Cells(sR - 1, 7)))
  56.         mDate2 = DateSerial(Year(Cells(sR, 7)), Month(Cells(sR, 7)), Day(Cells(sR, 7)))
  57.     Loop Until sR > LstR
  58.     '恢復原狀, 方便查核
  59.     [A1].Resize(LstR2, 9).Sort _
  60.             Key1:=[A1], Order1:=xlAscending, _
  61.             Header:=xlYes
  62. End Sub
複製代碼

TOP

RCRG
　暱稱: RCRG滾奶滾企

中學生Rank: 2

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


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

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

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

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
8#
發表於 2015-12-14 14:11 | 只看該作者
針對 規則2 修正:
試試看:
  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.     [H2:J65536] = ""
  12.     '清除底色, 如你原有底色的需求, 請將下列去除
  13.     [C:I].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.         cnt = sR
  24.         Do
  25.             sR = sR + 1
  26.             If sR = 2 Then GoTo Next1:
  27.             '規則1.製造日相同, 但到期日不同
  28.             If Int(Cells(sR, 7)) = Int(Cells(sR - 1, 7)) And Cells(sR, 5) <> Cells(sR - 1, 5) Then
  29.                 Cells(sR - 1, 8) = "到期日異常1"
  30.                '加入底色, 如你原有底色的需求, 請將下兩列去除
  31.                 Cells(sR - 1, 8).Interior.ColorIndex = 8
  32.                 Cells(sR - 1, 3).Resize(1, 5).Interior.ColorIndex = 8
  33.                 Cells(sR, 8) = "到期日異常1"
  34.                '加入底色, 如你原有底色的需求, 請將下兩列去除
  35.                 Cells(sR, 8).Interior.ColorIndex = 8
  36.                 Cells(sR, 3).Resize(1, 5).Interior.ColorIndex = 8
  37.             End If
  38.         Loop Until Cells(sR, 3) <> Cells(sR - 1, 3) Or sR > LstR  '直到 號碼不同 或 資料結尾
  39.         '規則2. 到期日也必須排序
  40.         If sR - cnt <= 1 Then GoTo Next1:
  41.         For I = cnt To sR - 2
  42.             minDate = Application.Min(Cells(I + 1, 5).Resize(sR - I - 1, 1))
  43.             If Cells(I, 5) > minDate Then
  44.                 Cells(I, 9) = "到期日異常2"
  45.                '加入底色, 如你原有底色的需求, 請將下兩列去除
  46.                 Cells(I, 9).Interior.ColorIndex = 38
  47.                 Cells(I, 3).Resize(1, 5).Interior.ColorIndex = 38
  48.             End If
  49.         Next
  50. Next1:
  51.     Loop Until sR > LstR  '直到資料結尾
  52.     '恢復原狀, 方便查核
  53.     [A1].Resize(LstR2, 9).Sort _
  54.             Key1:=[A1], Order1:=xlAscending, _
  55.             Header:=xlYes
  56. End Sub
複製代碼
執行結果如下圖:

TOP

RCRG
　暱稱: RCRG滾奶滾企

中學生Rank: 2

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


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

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
10#
發表於 2015-12-19 04:56 | 只看該作者
Q2:另外A欄的序號用意是？這是一定都會出現嗎?
VBA52列不是說的很清嗎?
如無此需求, 則相關VBACode去悼即可.
Q1:這不是你自己訂的規則2.嗎?如下圖:

test.jpg (1.61 KB)

test.jpg

TOP

        靜思自在 : 一個人的快樂．不是因為他擁有得多，而是因為他計較得少。
123
返回列表 上一主題