检查A列数据有效性规则，请老师指导谢谢！！

hcy1185

我的a列是序号，想使用代码检查是否符合要求。序号下单元格有空格、全角（一）、半角(一)、1、1.1、1.1.1、1.1.1.1、1.1.1.1.1等，下面这段代码是论坛老师的，想修改一下，请老师指导一下。谢谢！！



Sub CheckDataValidity()
    Dim ws As Worksheet, cell As Range, strName As String
    Set ws = ThisWorkbook.Worksheets(1)
    strName = " （）一二三四五六七八九十().1234567890"
    ' 遍历A列每个单元格
    For Each cell In ws.Range("A:A")
        ' 检查单元格是否符合指定的数据有效性规则
        If Not InStr(strName, Left(cell, 1)) Then
            MsgBox "单元格" & cell.Address & "的数据无效"
        End If
    Next cell
End Sub

tanglf188

怎么改？是要多判断范围还是把全角转半角？

hcy1185

tanglf188 发表于 2024-5-13 09:11
怎么改？是要多判断范围还是把全角转半角？

感谢老师！不转换，单元格内容包含字符串的一个元素就符合要求，一~十，0~9，（），()

hcy1185

已解决！在网上搜集的
Sub xvhao_jiancha()
    Dim ws As Worksheet, cell As Range
    Dim lastrow As Long, Endrow As Long
    Dim originalStr As String, originalStr2 As String
    Dim arr As Variant, myChar As Variant
   
    Set ws = ActiveSheet 'ThisWorkbook.Worksheets(1)
    lastrow = Cells.Find("序号", Cells(Rows.Count, 1), xlValues, xlWhole, xlByRows, xlPrevious).Offset(1).row
    Endrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row
    originalStr = " （）一二三四五六七八九十().1234567890"
   
    For Each cell In ws.Range("A" & lastrow & ":A" & Endrow)
        'cell.NumberFormat = "@"'设置文本格式
        'cell.Value = "'" & cell.Value
        originalStr2 = cell.Value
        arr = StringToArray(originalStr2) '自定义函数，无分隔符的字符串进数组Application.WorksheetFunction.
        For Each myChar In arr
            If InStr(1, originalStr, myChar, vbTextCompare) <= 0 Or Mid(originalStr2, 1, 1) = 0 Then '序号不能是0.1
                cell.Select '定位到单元格
                'cell.Interior.ColorIndex = 3
                cell.Interior.Color = RGB(255, 255, 0) ' 设置RGB颜色值为黄色
                Debug.Print cell.Address, cell.Value
                Stop '断点
                'MsgBox "单元格" & cell.Address & "不符合序号规则！"
                Exit For
            End If
        Next myChar
    Next cell
    MsgBox "A列单元格全部符合序号规则！"
    ws.Range("A" & lastrow & ":A" & Endrow).Interior.Pattern = xlNone '取消单元格底纹
End Sub
Function StringToArray(ByVal inputStr As String) As Variant
    Dim charArray() As Variant, i As Integer
   
    ReDim charArray(Len(inputStr)) ' 初始化数组大小
    For i = 1 To Len(inputStr) ' 遍历字符串的每个字符，并将其放入数组中
        charArray(i - 1) = Mid(inputStr, i, 1)
    Next i
    StringToArray = charArray ' 返回数组
End Function