Astuces Excel
  1. Astuces Excel
  3. Ignorer les alphabets dans une cellule, seuls les numbers doivent être vérifiés
Intereting Posts
Comment puis-je get l'ordre de la feuille selon les besoins indépendamment de l'ordre des feuilles dans excel Les compléments ne sont pas chargés lors de l'ouverture du file Excel par programme Impression avec excel et java ou autres Éliminer l'utilisation de «2 points» lors de l'utilisation d'Excel Interop Com Objects – C # Word VBA: formatting conditionnel de l'ombrage de cellule en fonction de la valeur Excel Conditionnel Max / Min sur datatables orientées horizontalement PHPExcel Supprime les lignes par ID DataTable.Select throws EvaluateException: Impossible d'effectuer une opération '=' sur System.Double et System.Ssortingng Après avoir importé CSV dans R, les en-têtes ne sont pas ce que je veux Excel VBA: répartition des échelles échelonnées avec 2d données de masortingce Comment renvoyer un tableau entre deux arrays en fonction d'une valeur de cellule dans la google spreadsheet? Découper la cellule avec plusieurs returns de chariot Comment faire automatiquement «Text to columns» et «save as» dans VBA? Comment déterminer une formule pour le time d'exécution count tenu des données quantitatives, Excel, lignes de tendance, Monte Carlo simulation Besoin de copyr et coller de plusieurs feuilles différentes en une seule feuille verticalement

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