忽略單元格中的字母，只應檢查數字

Question

Sub highlight(phm as variant) 
Dim w As Workbook 
Dim sh As Worksheet 
Dim x As Integer 
Dim rn As Range 
Dim k As Long 
Dim number() As integer 

If phm <> 0 Then 

phm = Split(phm, ",") 
ReDim number(LBound(phm) To UBound(phm)) As Integer 

Set sh = w.Worksheets("sheet1") 
sh.Select 
Cells.Find("Number Type").Select 

Set rn = sh6.UsedRange 
k = rn.Rows.Count + rn.Row - 1 
On Error Resume Next 
For i = 1 To k 
For j = LBound(number) To UBound(number) 
number(j) = CInt(phm(j)) 
If Err.number = 0 Then 
If ActiveCell.Value = number(j) Or IsEmpty(ActiveCell.Value) Then 
Selection.Interior.ColorIndex = xlNone 
Else 
Selection.Interior.Color = vbGreen 
Exit For 
End If 
End If 

Next j 
ActiveCell.Offset(1, 0).Select 'moves activecell down one row. 
Next i 


End If 
ActiveWorkbook.Save 


End Sub 

我想修改上述代碼，使字母在任何單元格中都被忽略。

例如，細胞可能含有「你好9811」，那麼它不應該被highlighted.Checking應該對數字只是做了在細胞

PHM包含這樣的數據：「9811,7849」等。 。

Answer 1

這是您程序的修改版本。該程序試圖將單元格的值轉換爲整數。只有在成功的情況下，Activecell.Value與number(j)相比較。基於變化的需求

Sub Test() 
    highlight ("9811,7849") 
End Sub 

Sub highlight(phm As Variant) 

    Dim w As Workbook 
    Dim sh As Worksheet 
    Dim x As Integer 
    Dim rn As Range 
    Dim k As Long 
    Dim number() As Integer 

    ' newly added variables 
    Dim TempNumber As Integer 
    Dim phmInt As Variant 
    Dim phmFound As Boolean 

    If phm <> 0 Then 

     ' split the numbers 
     phm = Split(phm, ",") 
     ReDim number(LBound(phm) To UBound(phm)) As Integer 

     Set sh = Worksheets("sheet1") 
     sh.Select 
     Cells.Find("Number Type").Select 

     Set rn = sh.UsedRange 
     k = rn.Rows.Count + rn.Row - 1 

     For i = 1 To k 

      On Error Resume Next 

      ' try to check if active cell is an integer 
      ' and proceed only if it is an integer 
      TempNumber = CInt(ActiveCell.Value) 
      If Err.number = 0 Then 
       On Error GoTo 0 

       ' set phmFound to false and then see if 
       ' active cell's value matches any item in phm array 
       phmFound = False 
       For Each phmInt In phm 
        If CInt(ActiveCell.Value) = CInt(phmInt) Then 
         phmFound = True 
         Exit For 
        End If 
       Next phmInt 

       ' if active cell's value matched at least one item 
       ' in phm array, don't colorize it. Otherwise colorize it 
       ActiveCell.Select 
       If phmFound Then 
        Selection.Interior.ColorIndex = xlNone 
       Else 
        Selection.Interior.Color = vbGreen 
       End If 

      End If 
      Err.Clear 

      ActiveCell.Offset(1, 0).Select 'moves activecell down one row. 
     Next i 

    End If 

End Sub 

編輯

要求

Sub Highlight() 

    ...same code as yours... 

    Cells.Find("hello").Select 
    ActiveCell.Offset(1, 0).Select 
    Set rn = sh.UsedRange 
    k = rn.Rows.Count + rn.Row - 1 

    ' ignore errors related to CInt conversion that will follow 
    On Error Resume Next 

    For x = 1 To k 
     For j = 0 To UBound(number) 

     ' try to convert value to integer 
     TempNumber = CInt(ActiveCell.Value) 

     ' if value was an integer, work on it 
     If Err.number = 0 Then 
      If ActiveCell.Value <> number(j) Then 
       Selection.Interior.Color = vbYellow 
      Else 
       Selection.Interior.ColorIndex = xlNone 
       Exit For 
      End If 
     End If 

     Next j 

     ActiveCell.Offset(1, 0).Select 'moves activecell down one row. 

    Next x 

End Sub 

編輯：9811和7848中輸入所以在這個任意單元格格式 - 你好9811,9811,7848， abc 7848不應突出顯示...除上述內容以外的其他內容的剩餘單元格應突出顯示

次測試（） 亮點（ 「9811,7848」） 結束小組

Sub highlight(phm As Variant) 

    Dim w As Workbook 
    Dim sh As Worksheet 
    Dim x As Integer 
    Dim rn As Range 
    Dim k As Long 
    Dim number() As Integer 

    ' newly added variables 
    Dim TempNumber As Integer 
    Dim phmInt As Variant 
    Dim phmFound As Boolean 

    If phm <> 0 Then 

     ' split the numbers 
     phm = Split(phm, ",") 
     ReDim number(LBound(phm) To UBound(phm)) As Integer 

     Set sh = Worksheets("sheet1") 
     sh.Select 
     Cells.Find("Number Type").Select 

     Set rn = sh.UsedRange 
     k = rn.Rows.Count + rn.Row - 1 

     For i = 1 To k 

      ' does the cell have the number we are looking for? 
      phmFound = False 
      For Each phmInt In phm 
       TempNumber = InStr(Trim(ActiveCell.Text), CStr(phmInt)) 
       If TempNumber > 0 Then 
        ' check if there is any number after phmint 
        If Not IsNumeric(Mid(Trim(ActiveCell.Text), TempNumber + Len(CStr(phmInt)), 1)) Then 
         phmFound = True 
         Exit For 
        End If 
       End If 
      Next phmInt 

      ' if active cell's value matched at least one item 
      ' in phm array, don't colorize it. Otherwise colorize it 
      ActiveCell.Select 
      If phmFound Then 
       Selection.Interior.ColorIndex = xlNone 
      Else 
       Selection.Interior.Color = vbGreen 
      End If 

      ActiveCell.Offset(1, 0).Select 'moves activecell down one row. 
     Next i 

    End If 

End Sub 

Answer 2

嘗試增加功能，以您的代碼

例如

Public Function OnlyDigits(pInput As String) As String 
    Dim objRegExp As Object 
    Set objRegExp = CreateObject("VBScript.RegExp") 
    With objRegExp 
     .Global = True 
     .Pattern = "\D" 
     OnlyDigits = .replace(pInput, vbNullString) 
    End With 
    Set objRegExp = Nothing 
End Function 

這裏是完整的代碼。

Sub highlight(phm As Variant) 
    Dim w   As Workbook 
    Dim sh   As Worksheet 
    Dim x   As Integer 
    Dim rn   As Range 
    Dim k   As Long 
    Dim Number() As Integer 

    If phm <> 0 Then 
    phm = Split(phm, ",") 
    ReDim Number(LBound(phm) To UBound(phm)) As Integer 

    Set sh = w.Worksheets("sheet1") 
    sh.Select 
    Cells.Find("Number Type").Select 

    Set rn = sh6.UsedRange 
    k = rn.Rows.count + rn.Row - 1 
    On Error Resume Next 
    For i = 1 To k 
     For j = LBound(Number) To UBound(Number) 
      Number(j) = CInt(phm(j)) 
       If Err.Number = 0 Then 
        If Val(OnlyDigits(ActiveCell.Value)) = Number(j) Or IsEmpty(ActiveCell.Value) Then 
         Selection.Interior.ColorIndex = xlNone 
        Else 
         Selection.Interior.Color = vbGreen 
         Exit For 
        End If 
       End If 
      Next j 
      ActiveCell.Offset(1, 0).Select 'moves activecell down one row. 
     Next i 
    End If 
    ActiveWorkbook.Save 
End Sub 

Public Function OnlyDigits(pInput As String) As String 
    Dim objRegExp As Object 
    Set objRegExp = CreateObject("VBScript.RegExp") 
    With objRegExp 
     .Global = True 
     .Pattern = "\D" 
     OnlyDigits = .replace(pInput, vbNullString) 
    End With 
    Set objRegExp = Nothing 
End Function