Plausibility check via VBA

[Paul_Hossler]

try this

You didn't say what to do with HALLO so I didn't

BTW, you mispelt the Voume worksheet tab, so I changed it to Volume

Suggestion: Instead of a MsgBox, you might want to list errors on a seperate sheet and/or color code them

Option Explicit


'The following rule applies to all sheets: if a value is missing in columns A,B,C (as in the Volume sheet), then this is an error
'The following rule applies to the Sales/Volume sheet: All values ??in columns D-O must be positive numbers and must not be >100.
'The following applies to the Costs sheet: All values ??in columns D-O must be negative numbers and must not be >-100.


Dim sMsg As String


Sub Plaus()
    Dim wsSales As Worksheet, wsVolume As Worksheet, wsCosts As Worksheet
    Dim rSales As Range, rVolume As Range, rCosts As Range, rCell As Range
    
    Set wsSales = Worksheets("Sales")
    Set wsVolume = Worksheets("Volume")
    Set wsCosts = Worksheets("Cost")
    
    Set rSales = wsSales.Cells(1, 1).CurrentRegion
    Set rVolume = wsVolume.Cells(1, 1).CurrentRegion
    Set rCosts = wsCosts.Cells(1, 1).CurrentRegion


    sMsg = vbNullString


    Call Col123(rSales)
    Call Col123(rVolume)
    Call Col123(rCosts)
    
    Call Num(rSales, 0#, 99.999999)
    Call Num(rVolume, 0#, 99.999999)
    Call Num(rCosts, -99.999999, 0#)
    


    MsgBox sMsg


End Sub


Private Sub Col123(r As Range)
    Dim rCell As Range, r1 As Range
    
    With r
    
        Set r1 = .Cells(1, 1).Resize(.Rows.Count, 3)
    
        On Error Resume Next
        For Each rCell In r1.SpecialCells(xlCellTypeBlanks)
            sMsg = sMsg & vbCrLf & rCell.Parent.Name & "- Cell " & rCell.Address
        Next
        On Error GoTo 0
    End With


End Sub




Private Sub Num(r As Range, L As Double, H As Double)
    Dim rCell As Range, r1 As Range
    
    With r
    
        Set r1 = .Cells(2, 4).Resize(.Rows.Count - 1, .Columns.Count - 3)
    
        On Error Resume Next
        For Each rCell In r1.SpecialCells(xlCellTypeConstants, xlNumbers)
            If Not (L <= rCell.Value And rCell.Value <= H) Then
                sMsg = sMsg & vbCrLf & rCell.Parent.Name & "- Cell " & rCell.Address
            End If
        Next
        On Error GoTo 0
    End With


End Sub