Selecting only cells in Excel with VBA that are numeric for calculation

user_18773119 0
Viewed 38

I few days ago I wrote several lines of code that should take two Excel files and compare each sheet for changes. The changes and the corresponding sheet are marked in yellow. Now I only want to give used cells a color that have a specific difference. For example only cells which have a difference of > 1000000. I tried CDBl and .isnumeric but I am not able to get a solution.

Sub Excelcomparison()
Dim Msg As String
Dim Old As String
Dim DataOld As String
Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet


MsgOne = "Select old file for comparison"
Style = vbOKOnly

Response = MsgBox(MsgOne, Style)
Neu = Application.GetOpenFilename("Excel (*.xlsx), *.xlsx")
DataOld = Mid(Old, InStrRev(Old, "\") + 1)

Workbooks.Open Filename:=Old

Set wb1 = ThisWorkbook
Set wb2 = Workbooks(DataOld)

    For Each ws1 In wb1.Worksheets
      For Each ws2 In wb2.Worksheets
        If ws1.Name = ws2.Name Then
          For Each cell In ws1.UsedRange.Cells
            If cell.Value <> ws2.Range(cell.Address).Value Then
                On Error Resume Next
                cell.Interior.Color = vbYellow
                ws1.Tab.Color = vbYellow
            End If
          Next cell
        End If
      Next ws2
    Next ws1


End Sub
vba excel
2 Answers

Try replacing of:

           If cell.Value <> ws2.Range(cell.Address).Value Then
                On Error Resume Next
                cell.Interior.Color = Color
                ws1.Tab.Color = Color
            End If

with:

           If cell.Value <> ws2.Range(cell.Address).Value Then
                If isnumeric(cell.value) and isnumeric(ws2.Range(cell.Address).Value) then
                   If abs(CDbl(cell.value) - CDbl(ws2.Range(cell.Address).Value)) > 1000000 then
                      cell.Interior.Color = Color
                      ws1.Tab.Color = Color
                   End if
                End If
            End If
user_22333080

Highlight Cells Matching a Condition

Option Explicit

Sub Excelcomparison()
    
    ' Define constants.
    
    Const aMsg As String = "Select old file for comparison"
    Const nMsg As String = "Select new file for comparison " _
        & "(this file gets the markings)"
    Const MsgStyle As Long = vbOKOnly
    Const FileFilter As String = _
        "Microsoft Excel-Files (*.xlsx; *xls; *xlsm), *.xlsx; *xls; *xlsm"
    Const InputPrompt = "Choose color for markings:" & vbLf & _
       "   'Yellow' or" & vbLf & _
       "   'Red' or" & vbLf & _
       "   'Blue' or" & vbLf & _
       "   'Green' or" & vbLf & _
       "   'Cyan':"
    Const Diff As Double = 1000000
    
    ' Choose the files to compare.
    MsgBox aMsg, MsgStyle
    Dim aPath As String: aPath = Application.GetOpenFilename(FileFilter)
    MsgBox nMsg, MsgStyle
    Dim nPath As String: nPath = Application.GetOpenFilename(FileFilter)
    
    ' Choose the color.
    
    Dim ChosenColor As String:
    ChosenColor = InputBox(Prompt:=InputPrompt)
    
    Dim Farbe As Long
    
    Select Case LCase(ChosenColor)
        Case "yellow": Farbe = vbYellow
        Case "red": Farbe = vbRed
        Case "blue": Farbe = vbBlue
        Case "green": Farbe = vbGreen
        Case "cyan": Farbe = vbCyan
        Case Else
            MsgBox "No color chosen.", vbCritical
            Exit Sub
    End Select
    
    ' Open the files.
    Dim awb As Workbook: Set awb = Workbooks.Open(Filename:=aPath)
    Dim nwb As Workbook: Set nwb = Workbooks.Open(Filename:=nPath)
    
    Dim aws As Worksheet
    Dim aValue As Variant
    Dim nws As Worksheet
    Dim nrg As Range
    Dim nurg As Range
    Dim nCell As Range
    Dim nValue As Variant
    
    ' Compare.
    For Each nws In nwb.Worksheets
        On Error Resume Next
            Set aws = awb.Worksheets(nws.Name)
        On Error GoTo 0
        If Not aws Is Nothing Then ' 'nws' found in 'awb'
            Debug.Print aws.Name, nws.Name
            Set nrg = nws.UsedRange
            For Each nCell In nrg.Cells
                nValue = nCell.Value
                If VarType(nValue) = vbDouble Then ' is a number
                    Debug.Print nCell.Address, nValue
                    aValue = aws.Range(nCell.Address).Value
                    If VarType(aValue) = vbDouble Then ' is a number
                        ' Compare values.
                        If Abs(nValue - aValue) > Diff Then ' condition is true
                            If nurg Is Nothing Then ' first cell
                                Set nurg = nCell
                            Else ' all other cells
                                Set nurg = Union(nurg, nCell)
                            End If
                        'Else ' condition is false
                        End If
                    End If
                End If
            Next nCell
            nrg.Interior.Color = xlNone
            If Not nurg Is Nothing Then ' found cells where condition is true
                Debug.Print nurg.Address
                nws.Tab.Color = Farbe
                nurg.Interior.Color = Farbe
                Set nurg = Nothing
            Else  ' no cells found where condition is true
                nws.Tab.Color = False
            End If
            Set aws = Nothing
        Else ' 'nws' not found in 'awb'
            nws.Tab.Color = False
        End If
    Next nws
    
    ' Close the workbook containing this code.
    'ThisWorkbook.Close

End Sub
user_98140690
Related