Datavalidering af sum

ja via vba kode, således at en event aktiveres hver gang at der tastes et beløb i en af de 3 celler.
Hvis tallet så er større en 1 så advarer den eller slettet det, eller hvad du nu vil have og det samme sker hvis der indtastet et bogstav.

Er cellerne ved siden af hinanden?

Indlægges under relevante ark

Dim kolonner As Variant
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sum As Variant

Rem opsætning af kolonner
    kolonner = Array(1, 3, 5)    'Tilpas - her kolonne A, C & E
Rem Er det i en af de 3 kolonner
    If erKolonneRelevant(Target.Column) = True Then
Rem Er alle 3 kolonner udfyldt
        If kolonnerUdfyldt(Target.Row, sum) = 3 Then
            If sum <> 1 Then
                MsgBox ("Sum i række " & CStr(Target.Row) & " er <> 1")
            End If
        End If
    End If
End Sub
Private Function erKolonneRelevant(kolNr)
Dim x As Byte
    For x = 0 To UBound(kolonner)
        If kolNr = kolonner(x) Then
            erKolonneRelevant = True
            Exit Function
        End If
    Next x
    erKolonneRelevant = False
End Function
Private Function kolonnerUdfyldt(rækNr, sum)
Dim x As Byte, antal As Byte
    antal = 0
    sum = 0
   
    For x = 0 To UBound(kolonner)
        If Cells(rækNr, kolonner(x)) <> "" Then
            antal = antal + 1
            sum = sum + Cells(rækNr, kolonner(x))
        End If
    Next x
    kolonnerUdfyldt = antal
End Function

Ja, cellerne er i samme række og ved siden af hinanden.

Jeg forstår ikke helt hvad al den kode gør, eller hvordan jeg skal kunne lægge den på arket?

Højreklik på arkfanen - Vis Programkode - Indsæt ovennævnte kode heri. Tilpas kolonnerne - som anført

-

Ellers - send en mail  - min adr. under profil

Oplys hvilke kolonner det drejer sig om.

Jeg justerer og returnerer...

Ja, det bliver jeg vist nød til, jeg kan ikke ud fra den kode du har skrevet gennemskue hvor jeg skal rette til de celler jeg ønsker valideret...

Yup, nu virker det!  Mange tak :-)

Jeg har et tillægsspørgsmål: Koden bevirker at titlen i de to øverste rækker forsvinder hvis jeg prøver at rette i dem. Hvordan klarer jeg mon den?  Pointen er at de to øverste rækker i de valgte kolonner skal holdes fri af koden, da der skal stå tekst i dem alle?
(Hvordan giver jeg i øvrigt point for det tillægsspørgsmål?, der er 60 på spil)

Tillægsspørgsmål - er blevet korrigeret og fremsendt direkte

Er lidt interesseret i at se den samlede kode - om muligt
PFT

p5 - prøver at finde filen & vise den her. Ok - ellers giv signal.

Rem VERSION 2
Rem =========
Dim kolonner As Variant, flag As Boolean
Private Sub Worksheet_Activate()
    flag = False
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Rem opsætning af kolonner                          'E-F-G
    kolonner = Array(5, 6, 7)
   
    If flag = False Then
Rem Er det i en af de 3 kolonner
        If erKolonneRelevant(Target.Column) = True Then
            sletDeAndreKolonner Target.Row, Target.Column
        End If
    End If
End Sub
Private Function erKolonneRelevant(kolNr)
Dim x As Byte
    For x = 0 To UBound(kolonner)
        If kolNr = kolonner(x) Then
            erKolonneRelevant = True
            Exit Function
        End If
    Next x
    erKolonneRelevant = False
End Function
Private Sub sletDeAndreKolonner(rækNr, kolNr)
Dim x As Byte, kol As Byte
    flag = True
   
    For x = 0 To UBound(kolonner)
        kol = kolonner(x)
        If kol <> kolNr Then
            Cells(rækNr, kol) = ""
        End If
    Next x
    flag = False

End Sub

Hej igen - supertekst - det er altid rart at få inspiration herinde

Hej P5 - ok - det er du velkommen til..