- 帖子
- 4901
- 主題
- 44
- 精華
- 24
- 積分
- 4916
- 點名
- 21
- 作業系統
- Windows 7
- 軟體版本
- Office 20xx
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台北
- 註冊時間
- 2010-4-30
- 最後登錄
- 2025-1-24
|
6#
發表於 2011-3-4 18:54
| 只看該作者
回復 5# lai.k.h - Sub 多重欄位檢查()
- Dim A As Range, Mystr$, Ar(), ErrStr()
- Set 開始 = CreateObject("Scripting.Dictionary")
- Set 結束 = CreateObject("Scripting.Dictionary")
- Set 星期 = CreateObject("Scripting.Dictionary")
- Set 日期 = CreateObject("Scripting.Dictionary")
- Set 序號 = CreateObject("Scripting.Dictionary")
- With Sheet1
- .[D3:Q65536].Interior.ColorIndex = 0 'D~Q欄顏色清除
- For Each A In .Range(.[D3], .[D65536].End(xlUp)) 'D3開始做迴圈
- x = 0
- Mystr = Join(Application.Transpose(Application.Transpose(A.Resize(, 3))), Chr(10)) '用跳行字元連接D~F內容作索引字串
- 開始(Mystr) = Mid(Split(A.Offset(, 1), "-")(0), 3) 'E欄資料以-分割成2部分,第1部分第3碼開始為開始日期
- 結束(Mystr) = Split(A.Offset(, 1), "-")(1) 'E欄資料以-分割成2部分,第2部分為結束日期
- 'D欄向右6欄的位置如果不等於開始日期就改變顏色,並將錯誤文字存入陣列
- If Format(A.Offset(, 6), "yyyymmdd") <> 開始(Mystr) Then A.Offset(, 6).Interior.ColorIndex = 36: ReDim Preserve ErrStr(x): ErrStr(x) = "開始日期錯誤": x = x + 1
- 'D欄向右7欄的位置如果不等於結束日期就改變顏色,並將錯誤文字存入陣列
- If Format(A.Offset(, 7), "yyyymmdd") <> 結束(Mystr) Then A.Offset(, 7).Interior.ColorIndex = 36: ReDim Preserve ErrStr(x): ErrStr(x) = "結束日期錯誤": x = x + 1
-
- If IsEmpty(星期(Mystr)) Then '如果以Mystr為索引的星期是初始值
- 星期(Mystr) = A.Offset(, 8) '紀錄D欄向右8欄的值
- ElseIf A.Offset(, 8) <> 星期(Mystr) Then '否則就跟已存的值比較,如果不同
- 'D欄向右8欄變色,並將錯誤文字存入陣列
- A.Offset(, 8).Interior.ColorIndex = 36: ReDim Preserve ErrStr(x): ErrStr(x) = "拜訪星期期錯誤": x = x + 1
- End If
- If IsEmpty(日期(Mystr)) Then '如果以Mystr為索引的日期是初始值
- ReDim Preserve Ar(0) '布置一個只有1個元素的陣列
- Ar(0) = A.Offset(, 9) '此陣列第1個元素值是D欄向右9欄的值
- 日期(Mystr) = Ar '把陣列作為字典物件內容
- ElseIf IsError(Application.Match(A.Offset(, 9), 日期(Mystr), 0)) Then '如果D欄向右9欄的值在字典物件(此處會是一個陣列)內找不到
- Ar = 日期(Mystr) '先取出字典物件內容傳給陣列變數
- s = UBound(Ar) + 1 '紀錄陣列上限值(擴充陣列)
- ReDim Preserve Ar(s) '陣列新元素
- Ar(s) = A.Offset(, 9)
- 日期(Mystr) = Ar '將以擴大的陣列傳回字典物件
- Else '否則(日期已經存在)
- 'D欄向右9欄變色,並將錯誤文字存入陣列
- A.Offset(, 9).Interior.ColorIndex = 36: ReDim Preserve ErrStr(x): ErrStr(x) = "拜訪日期重複": x = x + 1
- End If
- '序號做法與日期相同,不再累述
- If IsEmpty(序號(Mystr)) Then
- ReDim Preserve Ar(0)
- Ar(0) = A.Offset(, 12)
- 序號(Mystr) = Ar
- ElseIf IsError(Application.Match(A.Offset(, 12), 序號(Mystr), 0)) Then
- Ar = 序號(Mystr)
- s = UBound(Ar) + 1
- ReDim Preserve Ar(s)
- Ar(s) = A.Offset(, 12)
- 序號(Mystr) = Ar
- Else
- A.Offset(, 12).Interior.ColorIndex = 36: ReDim Preserve ErrStr(x): ErrStr(x) = "序號重複": x = x + 1
- End If
- '如果錯誤字串陣列元素數量不等於0,就表示有錯誤,D欄向右13欄變色,並寫入以\連接的錯誤文字,否則就清除
- If x > 0 Then A.Offset(, 13).Interior.ColorIndex = 35: A.Offset(, 13) = Join(ErrStr, "\") Else A.Offset(, 13) = ""
- Erase ErrStr '錯誤字串的陣列清空
- Next
- End With
- End Sub
複製代碼 |
|