扩展数据验证功能的VBA代码

dingmurch

因为系统自带的圈释无效数据只能告诉你非法单元格超过了255个，比较鸡肋
借助论坛的帮助，完成了一个用于判断数据有效性的函数
五个参数组合分别可以是
10000，用于统计当前工作表存在数据有效性的单元格总数和非法的单元格数量
11000，用于统计当前工作表存在数据有效性的单元格总数和非法的单元格数量，并把非法单元涂色
10100，将非法单元格的行，列数据输出到TXT文件
10010，将非法单元格的行，列数据输出本工作簿的新工作表
10001，将非法单元格的行，列数据输出新工作簿的新工作表
代码如下
Function Dingmurch02FU_0112_Vali(FB0112ID1 As Integer, FB0112ID2 As Integer, FB0112ID3 As Integer, FB0112ID4 As Integer, FB0112ID5 As Integer)
'【B对应功能】
'【C调试时间】2023.03.03
'【D简单描述】
'01统计无效数量+02填充颜色+03输出到txt+04输出到新表+05输出到新簿
'For r = 1 To d.Count
'    .Hyperlinks.Add anchor:=.Cells(r, 1), Address:="", SubAddress:=sht & "!" & .Cells(r, 1).Value
'Next r
Dim cell As Range, d, sht$, r
Set d = CreateObject("scripting.dictionary")
Dingmurch10PB_01PRO_99REC_NAME = ""
On Error GoTo GBXXxx_NOT
GBXXxx_qty = ActiveSheet.Cells.SpecialCells(xlCellTypeAllValidation).Cells.Count
If GBXXxx_qty > 0 Then
        GBXXxx_qofnot = 0
        For Each cell In ActiveSheet.Cells.SpecialCells(xlCellTypeAllValidation)
                On Error Resume Next
                If Not cell.Validation.Value Then
                        d.Add cell.Address, ActiveSheet.Name
                        If FB0112ID2 = 1 Then
                                cell.Interior.color = 65535
                        End If
                        If FB0112ID3 = 1 Then
                                Dingmurch10PB_01PRO_99REC_NAME = Dingmurch10PB_01PRO_99REC_NAME & vbCrLf & ActiveWorkbook.Name & ActiveSheet.Name & "|行" & cell.Row & "|列" & cell.Column
                        End If
                        GBXXxx_qofnot = GBXXxx_qofnot + 1
                Else
                End If
        Next
        If FB0112ID1 = 1 Then
                MsgBox GBXXxx_qty & "个单元格有数据验证" & GBXXxx_qofnot & "个单元格存在无效数据"
        End If
        If FB0112ID3 = 1 Then
                On Error GoTo myexit
                Set FSO = CreateObject("scripting.filesystemobject")
                Set TX = FSO.createTextfile(ActiveWorkbook.Path & "\" & "错误记录.txt", 1)
                TX.writeline Dingmurch10PB_01PRO_99REC_NAME
                TX.Close
myexit:
                Set FSO = Nothing
                Set TX = Nothing
                Dingmurch10PB_01PRO_99REC_NAME = ""
        End If
        If FB0112ID4 = 1 Then
                GBXXxx_temp = 0
                For Each Mysht In Worksheets
                        If Mysht.Name = "无效数据" Then GBXXxx_temp = GBXXxx_temp + 1
                Next
                If GBXXxx_temp = 0 Then Sheets.Add.Name = "无效数据"
                With Sheets("无效数据")
                        .Columns(1).ClearContents
                        .Columns(2).ClearContents
                        .[b1].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
                        .[a1].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.Items)
                End With
        End If
        If FB0112ID5 = 1 Then
                Workbooks.Add
                WDto = ActiveWorkbook.Name
                Windows(WDto).Activate
                With Sheets("sheet1")
                        .Columns(1).ClearContents
                        .Columns(2).ClearContents
                        .[b1].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
                        .[a1].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.Items)
                End With
        End If
End If
GoTo GBXXxx_END
GBXXxx_NOT: MsgBox "本表不存在数据验证"
GBXXxx_END:
End Function