[英]Selecting only cells in Excel with VBA that are numeric for calculation
I few days ago I wrote several lines of code that should take two Excel files and compare each sheet for changes.几天前,我写了几行代码,应该使用两个 Excel 文件并比较每个工作表的更改。 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.例如,只有差异大于 1000000 的单元格。我尝试了 CDBl 和 .isnumeric 但我无法获得解决方案。
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
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
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.