Lægge til værdi i celle

en makro er svaret........ jeg har lavet det før..... kigger lige i arkivet

ok

venter spændt, men en makro skal man selv køre ikke..? Det skal jo være sådan at jeg bare skal plotte tallet ind i cellen uden at skulle lave andet først.

Højreklik på arkets faneblad og vælg vis kode....
Indsæt følgende kode:

Private mdValue As Double
Private mdValueTemp As Double

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rCalcCells As Range
    Set rCalcCells = Range("A2:A50")

    If Not Intersect(Target, rCalcCells) Is Nothing Then
        mdValueTemp = mdValue
        mdValue = 0
        Target.Value = Target.Value + mdValueTemp
    End If

    Set rCalcCells = Nothing
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim rCalcCells As Range
    Set rCalcCells = Range("A2:A50")

    If Not Intersect(Target, rCalcCells) Is Nothing Then
        mdValue = Target.Value
    End If

    Set rCalcCells = Nothing
End Sub


Ret de to steder hvor der står "A2:A50" til det område, hvor du gerne vil have at funktionen skal virke.

Makro'en kører af sig selv........ den reagerer på at du skriver noget i det område, som er repræsenteret af "A2:A50"

Det virker godt nok, men når jeg markere dete hele laver den en error 13! ved du hvad det er eller?

Ja, den laver fejl, hvis du markerer flere celler i området på en gang....

Du kan tilføje, så koden ser således ud.....



Private mdValue As Double
Private mdValueTemp As Double

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rCalcCells As Range
    Set rCalcCells = Range("A2:A50")

    On Error Resume Next
    If Not Intersect(Target, rCalcCells) Is Nothing Then
        mdValueTemp = mdValue
        mdValue = 0
        Target.Value = Target.Value + mdValueTemp
    End If
    On Error GoTo 0

    Set rCalcCells = Nothing
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim rCalcCells As Range
    Set rCalcCells = Range("A2:A50")

    On Error Resume Next
    If Not Intersect(Target, rCalcCells) Is Nothing Then
        mdValue = Target.Value
    End If
    On Error GoTo 0

    Set rCalcCells = Nothing
End Sub


MEN MEN MEN........ hvis du så markerer flere celler og skriver den af dem der er aktiv........ så overskriver du det eksisterende tal med det nye......

Det har jeg endnu ikke en løsnning på..... men måske kommer den...!

jeg bruger bare den "gamle" kode tror jeg

Her er den nye kode, og den spiller :-)


Private mdValue As Double
Private mdValueTemp As Double
Private msCellAdr As String

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rCalcCells As Range
    Set rCalcCells = Range("A2:A50")
    Application.EnableEvents = False
   
    If Not Intersect(Target, rCalcCells) Is Nothing Then
        mdValueTemp = mdValue
        mdValue = 0
        If Selection.Rows.Count = 1 Then
            Target.Value = Target.Value + mdValueTemp
        Else
            Range(msCellAdr).Value = Range(msCellAdr).Value + mdValueTemp
            mdValue = ActiveCell.Value
            msCellAdr = ActiveCell.Address
        End If
    End If
   
    Application.EnableEvents = True
    Set rCalcCells = Nothing
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim rCalcCells As Range
    Set rCalcCells = Range("A2:A50")

    If Not Intersect(Target, rCalcCells) Is Nothing Then
        If Selection.Rows.Count = 1 Then
            mdValue = Target.Value
        Else
            mdValue = ActiveCell.Value
            msCellAdr = ActiveCell.Address
        End If
    End If

    Set rCalcCells = Nothing
End Sub

Ja nu virker det! :D tak for det

;-) nogle gange betaler lidt stædighed sig ;-)