1 Function DicCheck(ValueColum, dicColum) 2 '待检查数据列的表头 3 Dim valueColumnTitle As String 4 '待检查数据列的字典表头 5 Dim dicColumnTitle As String 6 '数据表格的行数 7 Dim valueRowCount As Long 8 '需要校验的sheet 9 Dim curMsgRow As Integer 10 11 Dim valueTitle As String 12 13 valueTitle = Sheets(valueSheetName).Cells(1, ValueColum) 14 15 valueRowCount = Sheets(valueSheetName).UsedRange.Rows.count 16 For i = dataRowStart To valueRowCount 17 cellValue = Sheets(valueSheetName).Cells(i, ValueColum) 18 If cellValue = "" Then 19 Exit Function 20 End If 21 If cellValue <> "" And DoDicCheck(cellValue, dicColum) = False Then 22 errorMsg = "第" & i & "行的数据项：" & valueTitle & "不符合规范，请检查!" 23 writeLog (errorMsg) 24 End If 25 26 Next i 27 End Function 28 '检查字典项是否合法 29 Function DoDicCheck(valueCol As TypeValueColum, rowIndex) 30 '字典sheet 31 value = Sheets(valueSheetName).Cells(rowIndex, valueCol.columnIndex) 32 For j = dataRowStart To Sheets(dicSheetName).UsedRange.Rows.count - 1 33 dicvalue = Sheets(dicSheetName).Cells(j, valueCol.dicColumnIndex) 34 If dicvalue = "" Then 35 Exit For 36 End If 37 If dicvalue = value Then 38 DoDicCheck = True 39 Exit Function 40 End If 41 Next j 42 If valueCol.dicColumnName = "民族" Or valueCol.dicColumnName = "国籍/地区" Then 43 errorMsg = "第" & rowIndex & "行的数据项：" & valueCol.columnName & "不符合规范，请检查" 44 writeLog (errorMsg) 45 Else 46 errorMsg = "第" & rowIndex & "行的数据项：" & valueCol.columnName & "不符合规范，请检查" & getTextByDicName(valueCol.dicColumnName, valueCol.dicColumnIndex) 47 writeLog (errorMsg) 48 End If 49 50 DoDicCheck = False 51 End Function 52 '根据字典名称，获得字典的内容 53 Function getTextByDicName(dicName, dicIndex) 54 Dim str As String 55 Dim count As Integer 56 str = "(" & dicName & "：" 57 For j = dataRowStart To Sheets(dicSheetName).UsedRange.Rows.count - 1 58 dicvalue = Sheets(dicSheetName).Cells(j, dicIndex) 59 If dicvalue <> "" Then 60 str = str + dicvalue + "、" 61 count = count + 1 62 Else 63 lastIndex = InStrRev(str, "、") 64 str = Application.WorksheetFunction.Substitute(str, "、", ")", count) 65 str = Application.WorksheetFunction.Substitute(str, "、", "和", count - 1) 66 getTextByDicName = str 67 Exit Function 68 End If 69 Next j 70 End Function 71 '校验长度是否符合要求，参数 72 'value:需要校验的内容 73 'length:限定长度 74 'strick:是否相等 75 Function CheckValueLength(valueCol As TypeValueColum, rowIndex, length, strick) 76 value = Sheets(valueSheetName).Cells(rowIndex, valueCol.columnIndex) 77 valueLength = Len(value) 78 79 If strick Then 80 If valueLength = length Then 81 CheckValueLength = True 82 Exit Function 83 Else 84 CheckValueLength = False 85 errorMsg = "第" & rowIndex & "行的数据项：" & valueCol.columnName & "必须为" & length & "位，请检查！" 86 writeLog (errorMsg) 87 Exit Function 88 End If 89 End If 90 If valueLength <= length Then 91 CheckValueLength = True 92 Exit Function 93 Else 94 CheckValueLength = False 95 errorMsg = "第" & rowIndex & "行的数据项：" & valueCol.columnName & "长度不能大于" & length & "位，请检查！" 96 writeLog (errorMsg) 97 Exit Function 98 End If 99 End Function 100 '获得内容的字节数 101 '返回字节长度 102 Function checkByteLength(value) 103 Dim byteLen As Integer 104 byteLen = 0 105 If IsEmpty(value) Then 106 Exit Function 107 End If 108 valueLength = Len(value) 109 For i = 1 To valueLength 110 If Abs(Asc(Mid(value, i, 1))) > 255 Then 111 byteLen = byteLen + 3 112 Else 113 byteLen = byteLen + 1 114 End If 115 Next i 116 checkByteLength = byteLen 117 End Function 118 119 '根据列查询是否有字典 120 '找到返回列索引 121 '找不到返回0 122 Function findDic(value) 123 Dim index As Integer 124 index = 1 125 Title = Sheets(dicSheetName).Cells(1, index) 126 While Title <> "" 127 128 If Title = value Then 129 findDic = index 130 Exit Function 131 End If 132 index = index + 1 133 Title = Sheets(dicSheetName).Cells(1, index) 134 Wend 135 findDic = 0 136 End Function 137 138 '是否为数字 139 '不是数字写入日志 返回 False 140 '是数字 返回 True 141 Function checkBeNumeric(valueCol As TypeValueColum, rowIndex) 142 Dim beNumeric As Boolean 143 value = Sheets(valueSheetName).Cells(rowIndex, valueCol.columnIndex) 144 beNumeric = IsNumeric(value) 145 If beNumeric Then 146 Else 147 errorMsg = "第" & rowIndex & "行的数据项：" & valueCol.columnName & "必须为数字，请检查！" 148 writeLog (errorMsg) 149 checkBeNumeric = False 150 Exit Function 151 End If 152 checkBeNumeric = True 153 End Function 154 '检查是否为20111001日期格式 155 '合法，返回True 156 '不合法，返回False 157 Function CheckIsDate(valueCol As TypeValueColum, rowIndex) 158 Dim beNumeric As Boolean 159 value = Sheets(valueSheetName).Cells(rowIndex, valueCol.columnIndex) 160 If Len(value) <> 8 Then 161 errorMsg = "第" & rowIndex & "行的数据项：" & valueCol.columnName & "格式不正确，请检查(例如：20121001)！" 162 writeLog (errorMsg) 163 CheckIsDate = False 164 Exit Function 165 End If 166 167 beNumeric = IsNumeric(value) 168 If beNumeric Then 169 170 Else 171 errorMsg = "第" & rowIndex & "行的数据项：" & valueCol.columnName & "格式不正确，请检查(例如：20121001)！" 172 writeLog (errorMsg) 173 CheckIsDate = False 174 Exit Function 175 End If 176 177 dateStr = Left(value, 4) & "/" & Mid(value, 5, 2) & "/" & Right(value, 2) 178 beDate = IsDate(dateStr) 179 If beDate Then 180 Else 181 errorMsg = "第" & rowIndex & "行的数据项：" & valueCol.columnName & "不合法，请检查(例如：20121001)！" 182 writeLog (errorMsg) 183 CheckIsDate = False 184 Exit Function 185 End If 186 CheckIsDate = True 187 End Function 188 '检查是否为20110101日期格式 189 '合法，返回True 190 '不合法，返回False 191 Function CheckBeDate(value) 192 Dim beNumeric As Boolean 193 If Len(value) <> 8 Then 194 CheckBeDate = False 195 Exit Function 196 End If 197 198 beNumeric = IsNumeric(value) 199 If beNumeric Then 200 Else 201 CheckBeDate = False 202 Exit Function 203 End If 204 205 dateStr = Left(value, 4) & "/" & Mid(value, 5, 2) & "/" & Right(value, 2) 206 beDate = IsDate(dateStr) 207 If beDate Then 208 Else 209 CheckBeDate = False 210 Exit Function 211 End If 212 CheckBeDate = True 213 End Function 214 '检查是否为201101日期格式 215 '合法，返回True 216 '不合法，返回False 217 Function CheckIsYmDate(valueCol As TypeValueColum, rowIndex) 218 Dim beNumeric As Boolean 219 value = Sheets(valueSheetName).Cells(rowIndex, valueCol.columnIndex) 220 If Len(value) <> 6 Then 221 errorMsg = "第" & rowIndex & "行的数据项：" & valueCol.columnName & "格式不正确，请检查(例如：201201)！" 222 writeLog (errorMsg) 223 CheckIsYmDate = False 224 Exit Function 225 End If 226 227 beNumeric = IsNumeric(value) 228 If beNumeric Then 229 230 Else 231 errorMsg = "第" & rowIndex & "行的数据项：" & valueCol.columnName & "格式不正确，请检查(例如：201201)！" 232 writeLog (errorMsg) 233 CheckIsYmDate = False 234 Exit Function 235 End If 236 237 dateStr = Left(value, 4) & "/" & Right(value, 2) & "/01" 238 beDate = IsDate(dateStr) 239 If beDate Then 240 Else 241 errorMsg = "第" & rowIndex & "行的数据项：" & valueCol.columnName & "不合法，请检查(例如：20120101)！" 242 writeLog (errorMsg) 243 CheckIsYmDate = False 244 Exit Function 245 End If 246 CheckIsYmDate = True 247 End Function 248 '比较两个日期大小 249 'date1>date2 返回1 250 'date1=date2 返回0 251 'date1<date2 返回-1 252 '其他返回2 253 Function compareDate(dateStr1, dateStr2) 254 Dim date1 As Date 255 Dim date2 As Date 256 If Len(dateStr1) <> 8 Or Len(dateStr2) <> 8 Then 257 compareDate = 2 258 Exit Function 259 End If 260 261 262 If IsNumeric(dateStr1) And IsNumeric(dateStr2) Then 263 Else 264 compareDate = 2 265 Exit Function 266 End If 267 268 date1 = Left(dateStr1, 4) & "/" & Mid(dateStr1, 5, 2) & "/" & Right(dateStr1, 2) 269 date2 = Left(dateStr2, 4) & "/" & Mid(dateStr2, 5, 2) & "/" & Right(dateStr2, 2) 270 If date1 - date2 > 0 Then 271 compareDate = 1 272 ElseIf date1 - date2 = 0 Then 273 compareDate = 0 274 Else 275 compareDate = -1 276 End If 277 End Function 278 '检查必填项 279 '空时返回0 280 '不为空时返回1 281 Function checkRequired(rowIndex, columnIndex) 282 '表头内容 283 Dim valueTitle As String 284 '单元格内容 285 Dim cellValue As String 286 287 valueTitle = Sheets(valueSheetName).Cells(1, columnIndex) 288 289 cellValue = Sheets(valueSheetName).Cells(rowIndex, columnIndex) 290 If cellValue = "" Then 291 checkRequired = 0 292 errorMsg = "第" & rowIndex & "行的数据项：" & valueTitle & "不能为空，请填写！" 293 writeLog (errorMsg) 294 Else 295 checkRequired = 1 296 End If 297 End Function 298 '检查身份证件号码是否合法 299 '不合法，返回0 300 '合法，返回1 301 '15位 升级18位 302 Function IDcheck(ID) 303 Dim s, i As Integer 304 Dim e, z As String 305 '----------------------------身份证号码合法性检查--------------------------------------- 306 If Not (Len(ID) = 18 Or Len(ID) = 15) Then '位数检验 307 IDcheck = 0 308 Exit Function 309 Else 310 If Len(ID) = 15 Then ID = Left(ID, 6) & "19" & Right(ID, 9) 311 If IsNumeric(Left(ID, 17)) = False Or InStr(ID, ".") > 0 Then '字符检验 312 IDcheck = 0 313 Exit Function 314 End If 315 On Error Resume Next '日期检验 316 If DateValue(Mid(ID, 7, 4) & "-" & Mid(ID, 11, 2) & "-" & Mid(ID, 13, 2)) < 1 Or _ 317 DateValue(Mid(ID, 7, 4) & "-" & Mid(ID, 11, 2) & "-" & Mid(ID, 13, 2)) > Date Then 318 IDcheck = 0 319 Exit Function 320 End If 321 End If 322 '-----------------------------校验码的生成及检查---------------------------------------- 323 s = 0 324 For i = 1 To 17 325 s = s + Val(Mid(ID, 18 - i, 1)) * (2 ^ i Mod 11) 326 Next 327 e = Mid("10X98765432", (s Mod 11) + 1, 1) '生成校验码 328 If Len(ID) = 18 Then 329 z = UCase(Right(ID, 1)) 330 If z = e Then '校验码对比 331 IDcheck = 1 332 Else 333 IDcheck = 0 '如果要返回校验码，请把本行语句改为：IDcheck = e 334 End If 335 Else 336 IDcheck = ID & e '15位身份证号码升位 337 End If 338 339 End Function 340 '校验电子邮箱 341 Function matchEmail(value) 342 Dim beIndex As Integer 343 beIndex = InStr(value, "@") 344 If beIndex = 0 Then 345 matchEmail = False 346 Exit Function 347 End If 348 matchEmail = True 349 End Function 350 '获取表头信息 351 Function getValueColumCount(sheetName) 352 index = 1 353 Title = Sheets(sheetName).Cells(1, index) 354 While Title <> "" 355 index = index + 1 356 Title = Sheets(sheetName).Cells(1, index) 357 Wend 358 getValueColumCount = index - 1 359 End Function 360 '删除日志 361 Function clearLog() 362 Sheets(msgSheetName).Columns(1).Delete 363 364 End Function 365 '写日志 366 Function writeLog(content As String) 367 Sheets(msgSheetName).Cells(curMsgRow, 1) = content 368 curMsgRow = curMsgRow + 1 369 End Function 370 371 '获得总列数 372 Function getColumnCount(sheetName) 373 index = 1 374 Title = Sheets(sheetName).Cells(1, index) 375 While Title <> "" 376 index = index + 1 377 Title = Sheets(sheetName).Cells(1, index) 378 Wend 379 getColumnCount = index - 1 - 2 380 End Function 381 '回填数据信息 382 Function fileXsExportModel(xep As TypeValueCell) 383 bb = getExportCell(xep) 384 If xep.cellContent <> "" Then 385 If xep.cellName = "班号" Then 386 If Len(xep.cellContent) = 7 Then 387 Dim jyjdInt As Integer 388 Dim bjStr As String 389 Dim bjMess As String 390 Dim njStr As String 391 Dim njMess As String 392 bjMess = "" 393 jyjdInt = Mid(xep.cellContent, 5, 1) 394 njStr = Mid(xep.cellContent, 1, 4) 395 bjStr = Mid(xep.cellContent, 6, 2) 396 If jyjdInt = 1 Then 397 njMess = "小学" & njStr & "级" 398 bjMess = bjStr & "班(" & xep.cellContent & ")" 399 ElseIf jyjdInt = 2 Then 400 njMess = "初中" & njStr & "级" 401 bjMess = bjStr & "班(" & xep.cellContent & ")" 402 ElseIf jyjdInt = 3 Then 403 njMess = "高中" & njStr & "级" 404 bjMess = bjStr & "班(" & xep.cellContent & ")" 405 End If 406 xep.cellContent = bjMess 407 Sheets(XsExportSheet).Cells(19, 3) = njMess 408 Sheets(XsExportSheet).Cells(xep.exportRow, xep.exportColumn) = xep.cellContent 409 End If 410 Else 411 If xep.cellName <> "学籍接续标识" Then 412 Sheets(XsExportSheet).Cells(xep.exportRow, xep.exportColumn) = xep.cellContent 413 End If 414 End If 415 Else 416 If xep.cellName <> "隐藏" Then 417 Sheets(XsExportSheet).Cells(xep.exportRow, xep.exportColumn) = "" 418 End If 419 End If 420 End Function 421 '清空模板信息 422 Function clearXsExportModel(xep As TypeValueCell) 423 Dim columnName As String 424 columnName = xep.cellName 425 If columnName <> "学籍接续标识" Then 426 bb = getExportCell(xep) 427 Sheets(XsExportSheet).Cells(xep.exportRow, xep.exportColumn) = "" 428 End If 429 '年级清空 430 Sheets(XsExportSheet).Cells(19, 3) = "" 431 End Function