Board logo

標題: 多重欄位檢查 [打印本頁]
作者: lai.k.h    時間: 2011-3-1 11:58     標題: 多重欄位檢查

各位老師如附檔內範例及說明，因實在不是真正很瞭解Dictionary及Array的用法，想了很久還是無法利用VBA程式完成，所以懇請各位老師能指導小弟一下，感謝。
作者: Hsieh    時間: 2011-3-2 08:43

回復 1# lai.k.h
  1. Sub nn()
  2. Dim A As Range, ErrStr$
  3. Set d = CreateObject("Scripting.Dictionary")
  4. Set d1 = CreateObject("Scripting.Dictionary")
  5. Set d2 = CreateObject("Scripting.Dictionary")
  6. Set dic3 = CreateObject("Scripting.Dictionary")
  7. [D3:L65536].Interior.ColorIndex = 0
  8. For Each A In Range([D3], [D65536].End(xlUp))
  9.     mystr = Join(Array(A, A.Offset(, 1).Value, A.Offset(, 2).Value), Chr(10))
  10.     If d.exists(mystr) = False Then d(mystr) = mystr: d1(mystr) = A.Offset(, 5).Value
  11.     If InStr(d2(mystr), A.Offset(, 6).Text) > 0 Then A.Offset(, 6).Interior.ColorIndex = 36: ErrStr = ErrStr & "拜訪日期重覆"
  12.     d2(mystr) = d2(mystr) & A.Offset(, 6).Text
  13.     If InStr(dic3(mystr), A.Offset(, 7).Text) > 0 Then A.Offset(, 7).Interior.ColorIndex = 36: ErrStr = ErrStr & "序號重複"
  14.     dic3(mystr) = dic3(mystr) & A.Offset(, 7).Text
  15.     If InStr(d(mystr), Format(A.Offset(, 3), "yyyymmdd")) = 0 Then A.Offset(, 3).Interior.ColorIndex = 36: ErrStr = ErrStr & "週期開始錯誤"
  16.     If InStr(d(mystr), Format(A.Offset(, 4), "yyyymmdd")) = 0 Then A.Offset(, 4).Interior.ColorIndex = 36: ErrStr = ErrStr & "結束時間錯誤"
  17.     If A.Offset(, 5).Value <> d1(mystr) Then A.Offset(, 5).Interior.ColorIndex = 36: ErrStr = ErrStr & "拜訪星期錯誤"
  18.     If ErrStr <> "" Then A.Offset(, 8) = ErrStr: A.Offset(, 8).Interior.ColorIndex = 35
  19.     ErrStr = ""
  20. Next
  21. End Sub
複製代碼
作者: lai.k.h    時間: 2011-3-3 14:10

非常感謝Hsieh老師的回覆，但是經過實際Run過後，發現在每筆序號12的位置皆會出現序號重覆的標示(如附件)，不知是那裡發生問題，另外若插入其他欄位如附件中的G,H,I,N,O五欄，但此五欄皆不做任何的比對的話，是否直接修改Offset值即可。
作者: Hsieh    時間: 2011-3-3 16:31

回復 3# lai.k.h
  1. Sub 多重欄位檢查()
  2. Dim A As Range, Mystr$, Ar(), ErrStr()
  3. Set 開始 = CreateObject("Scripting.Dictionary")
  4. Set 結束 = CreateObject("Scripting.Dictionary")
  5. Set 星期 = CreateObject("Scripting.Dictionary")
  6. Set 日期 = CreateObject("Scripting.Dictionary")
  7. Set 序號 = CreateObject("Scripting.Dictionary")

  9. With Sheet1
  10. .[D3:Q65536].Interior.ColorIndex = 0
  11. For Each A In .Range(.[D3], .[D65536].End(xlUp))
  12. x = 0
  13.     Mystr = Join(Application.Transpose(Application.Transpose(A.Resize(, 3))), Chr(10))
  14.     開始(Mystr) = Mid(Split(A.Offset(, 1), "-")(0), 3)
  15.     結束(Mystr) = Split(A.Offset(, 1), "-")(1)
  16.     If Format(A.Offset(, 6), "yyyymmdd") <> 開始(Mystr) Then A.Offset(, 6).Interior.ColorIndex = 36: ReDim Preserve ErrStr(x): ErrStr(x) = "開始日期錯誤": x = x + 1
  17.     If Format(A.Offset(, 7), "yyyymmdd") <> 結束(Mystr) Then A.Offset(, 7).Interior.ColorIndex = 36:  ReDim Preserve ErrStr(x): ErrStr(x) = "結束日期錯誤": x = x + 1
  18.     If IsEmpty(星期(Mystr)) Then
  19.        星期(Mystr) = A.Offset(, 8)
  20.        ElseIf A.Offset(, 8) <> 星期(Mystr) Then
  21.        A.Offset(, 8).Interior.ColorIndex = 36:  ReDim Preserve ErrStr(x): ErrStr(x) = "拜訪星期期錯誤": x = x + 1
  22.     End If
  23.     If IsEmpty(日期(Mystr)) Then
  24.     ReDim Preserve Ar(0)
  25.     Ar(0) = A.Offset(, 9)
  26.        日期(Mystr) = Ar
  27.        ElseIf IsError(Application.Match(A.Offset(, 9), 日期(Mystr), 0)) Then
  28.        Ar = 日期(Mystr)
  29.        s = UBound(Ar) + 1
  30.        ReDim Preserve Ar(s)
  31.        Ar(s) = A.Offset(, 9)
  32.        日期(Mystr) = Ar
  33.        Else
  34.        A.Offset(, 9).Interior.ColorIndex = 36: ReDim Preserve ErrStr(x): ErrStr(x) = "拜訪日期重複": x = x + 1
  35.     End If
  36.    
  37.     If IsEmpty(序號(Mystr)) Then
  38.     ReDim Preserve Ar(0)
  39.     Ar(0) = A.Offset(, 12)
  40.        序號(Mystr) = Ar
  41.        ElseIf IsError(Application.Match(A.Offset(, 12), 序號(Mystr), 0)) Then
  42.        Ar = 序號(Mystr)
  43.        s = UBound(Ar) + 1
  44.        ReDim Preserve Ar(s)
  45.        Ar(s) = A.Offset(, 12)
  46.        序號(Mystr) = Ar
  47.        Else
  48.        A.Offset(, 12).Interior.ColorIndex = 36: ReDim Preserve ErrStr(x): ErrStr(x) = "序號重複": x = x + 1
  49.     End If
  50.    If x > 0 Then A.Offset(, 13).Interior.ColorIndex = 35: A.Offset(, 13) = Join(ErrStr, "\") Else A.Offset(, 13) = ""
  51. Erase ErrStr
  52. Next
  53. End With
  54. End Sub
複製代碼
[attach]4906[/attach]
作者: lai.k.h    時間: 2011-3-4 18:18

感謝Hsieh老師的回覆，經過測試後已完全沒問題，雖以目前我的程度來說要完全瞭解實屬困難，但我還是會努力學習的，也希望若您有空可否加註說明，讓我能更加清楚其內容，再次感謝您。
作者: Hsieh    時間: 2011-3-4 18:54

回復 5# lai.k.h
  1. Sub 多重欄位檢查()
  2. Dim A As Range, Mystr$, Ar(), ErrStr()
  3. Set 開始 = CreateObject("Scripting.Dictionary")
  4. Set 結束 = CreateObject("Scripting.Dictionary")
  5. Set 星期 = CreateObject("Scripting.Dictionary")
  6. Set 日期 = CreateObject("Scripting.Dictionary")
  7. Set 序號 = CreateObject("Scripting.Dictionary")

  9. With Sheet1
  10. .[D3:Q65536].Interior.ColorIndex = 0 'D~Q欄顏色清除
  11. For Each A In .Range(.[D3], .[D65536].End(xlUp)) 'D3開始做迴圈
  12. x = 0
  13.     Mystr = Join(Application.Transpose(Application.Transpose(A.Resize(, 3))), Chr(10)) '用跳行字元連接D~F內容作索引字串
  14.     開始(Mystr) = Mid(Split(A.Offset(, 1), "-")(0), 3) 'E欄資料以-分割成2部分，第1部分第3碼開始為開始日期
  15.     結束(Mystr) = Split(A.Offset(, 1), "-")(1) 'E欄資料以-分割成2部分，第2部分為結束日期
  16.     'D欄向右6欄的位置如果不等於開始日期就改變顏色，並將錯誤文字存入陣列
  17.     If Format(A.Offset(, 6), "yyyymmdd") <> 開始(Mystr) Then A.Offset(, 6).Interior.ColorIndex = 36: ReDim Preserve ErrStr(x): ErrStr(x) = "開始日期錯誤": x = x + 1
  18.     'D欄向右7欄的位置如果不等於結束日期就改變顏色，並將錯誤文字存入陣列
  19.     If Format(A.Offset(, 7), "yyyymmdd") <> 結束(Mystr) Then A.Offset(, 7).Interior.ColorIndex = 36:  ReDim Preserve ErrStr(x): ErrStr(x) = "結束日期錯誤": x = x + 1
  20.    
  21.     If IsEmpty(星期(Mystr)) Then '如果以Mystr為索引的星期是初始值
  22.        星期(Mystr) = A.Offset(, 8) '紀錄D欄向右8欄的值
  23.        ElseIf A.Offset(, 8) <> 星期(Mystr) Then '否則就跟已存的值比較，如果不同
  24.        'D欄向右8欄變色，並將錯誤文字存入陣列
  25.        A.Offset(, 8).Interior.ColorIndex = 36:  ReDim Preserve ErrStr(x): ErrStr(x) = "拜訪星期期錯誤": x = x + 1
  26.     End If
  27.     If IsEmpty(日期(Mystr)) Then '如果以Mystr為索引的日期是初始值
  28.     ReDim Preserve Ar(0) '布置一個只有1個元素的陣列
  29.     Ar(0) = A.Offset(, 9) '此陣列第1個元素值是D欄向右9欄的值
  30.        日期(Mystr) = Ar '把陣列作為字典物件內容
  31.        ElseIf IsError(Application.Match(A.Offset(, 9), 日期(Mystr), 0)) Then '如果D欄向右9欄的值在字典物件(此處會是一個陣列)內找不到
  32.        Ar = 日期(Mystr) '先取出字典物件內容傳給陣列變數
  33.        s = UBound(Ar) + 1 '紀錄陣列上限值(擴充陣列)
  34.        ReDim Preserve Ar(s) '陣列新元素
  35.        Ar(s) = A.Offset(, 9)
  36.        日期(Mystr) = Ar '將以擴大的陣列傳回字典物件
  37.        Else '否則(日期已經存在)
  38.        'D欄向右9欄變色，並將錯誤文字存入陣列
  39.        A.Offset(, 9).Interior.ColorIndex = 36: ReDim Preserve ErrStr(x): ErrStr(x) = "拜訪日期重複": x = x + 1
  40.     End If
  41.     '序號做法與日期相同，不再累述
  42.     If IsEmpty(序號(Mystr)) Then
  43.     ReDim Preserve Ar(0)
  44.     Ar(0) = A.Offset(, 12)
  45.        序號(Mystr) = Ar
  46.        ElseIf IsError(Application.Match(A.Offset(, 12), 序號(Mystr), 0)) Then
  47.        Ar = 序號(Mystr)
  48.        s = UBound(Ar) + 1
  49.        ReDim Preserve Ar(s)
  50.        Ar(s) = A.Offset(, 12)
  51.        序號(Mystr) = Ar
  52.        Else
  53.        A.Offset(, 12).Interior.ColorIndex = 36: ReDim Preserve ErrStr(x): ErrStr(x) = "序號重複": x = x + 1
  54.     End If
  55.     '如果錯誤字串陣列元素數量不等於0，就表示有錯誤，D欄向右13欄變色，並寫入以\連接的錯誤文字，否則就清除
  56.    If x > 0 Then A.Offset(, 13).Interior.ColorIndex = 35: A.Offset(, 13) = Join(ErrStr, "\") Else A.Offset(, 13) = ""
  57. Erase ErrStr '錯誤字串的陣列清空
  58. Next
  59. End With
  60. End Sub
複製代碼
作者: lai.k.h    時間: 2011-3-5 22:15

謝謝~努力消化中
作者: FAlonso    時間: 2011-3-6 16:26

本帖最後由 FAlonso 於 2011-3-8 22:32 編輯

研讀了H大的程式
26-32行把ar和xxx(mystr)互調的把戲真是厲害



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