分割高亮

Sub DivideAndHighlight()
    Const PROC_TITLE As String = "Divide and Highlight"
    Const DIVISOR As Double = 1000
    Const HIGHLIGHT_COLOR As Long = vbYellow
    
    If Selection Is Nothing Then Exit Sub ' no visible workbooks open
    If Not TypeOf Selection Is Range Then Exit Sub ' not a range
    
    Dim urg As Range, cell As Range, cValue
    
    For Each cell In Selection.Cells
        If cell.Interior.Color <> HIGHLIGHT_COLOR Then
            cValue = cell.Value
            If VarType(cValue) = vbDouble Then ' is a number
                If urg Is Nothing Then
                    Set urg = cell
                Else
                    Set urg = Union(urg, cell)
                End If
            End If
        End If
    Next cell
    
    If urg Is Nothing Then
        MsgBox "No cells found.", vbExclamation, PROC_TITLE
        Exit Sub
    End If
    
    Dim arg As Range, Data, rCount As Long, cCount As Long, r As Long, c As Long
    
    For Each arg In urg.Areas
        
        rCount = arg.Rows.Count
        cCount = arg.Columns.Count
        
        If rCount * cCount = 1 Then
            ReDim Data(1 To 1, 1 To 1): Data(1, 1) = arg.Value
        Else
            Data = arg.Value
        End If
        
        For r = 1 To rCount
            For c = 1 To cCount
                Data(r, c) = Data(r, c) / DIVISOR
            Next c
        Next r
        
        arg.Value = Data
    
    Next arg
    
    urg.Interior.Color = HIGHLIGHT_COLOR
    
    MsgBox "Cells divided and highlighted.", vbInformation, PROC_TITLE
 
 End Sub