Ignorer les alphabets dans une cellule, seuls les numbers doivent être vérifiés

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 

Je souhaite modifier le code ci-dessus de telle manière que les alphabets soient ignorés si présents dans n'importe quelle cellule.

Par exemple, une cellule peut contenir "hello 9811", alors elle ne doit pas être mise en surbrillance. La vérification doit être effectuée uniquement sur les nombres dans la cellule

phm contient des données comme ceci: "9811,7849" etc.

Voici une version modifiée de votre programme. Le programme essaie de convertir la valeur de la cellule en un integer. Seul s'il réussit à le faire, Activecell.Value est comparé au number(j) .

 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 

EDIT basé sur le changement d'exigence

 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 

MODIFIER

Exigence: 9811 et 7848 sont entrés de sorte que n'importe quelle cellule dans ce format – hello 9811,9811,7848, abc 7848 ne doit PAS être mis en surbrillance … les autres cellules avec tout autre contenu autre que celui mentionné ci-dessus devraient être mis en surbrillance

Sub Test () surligné ("9811,7848") 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 ' 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 

Essayez d'append la fonction à votre code

Exemple

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

voici le code complet.

 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 Ssortingng) As Ssortingng Dim objRegExp As Object Set objRegExp = CreateObject("VBScript.RegExp") With objRegExp .Global = True .Pattern = "\D" OnlyDigits = .replace(pInput, vbNullSsortingng) End With Set objRegExp = Nothing End Function