Supportnet Computer
Planet of Tech

Supportnet / Forum / Tabellenkalkulation

Worksheet_SelectionChange





Frage

Hallo Wie kann ich folgendes Makro vereinfachen und zugleich erweitern, so dass im Bereich A1:A100,sobald auf eine Zelle geklickt wird, der Wert eingegeben wird. der um 1 grässer ist, als der grösste in diesem Bereich bereits eingetragene Wert. Die Formel in B1 lautet: =MAX(A1:A100) Mein bisheriges (kompliziertes) Makro funktioniert für den Bereich A1:A6 und lautet: Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) Dim Valor1 As String Valor1 = ActiveSheet.Range("B1") If Target.Cells.Address = "$A$1" Then Target.Cells = Valor1 + 1 Else End If If Target.Cells.Address = "$A$2" Then Target.Cells = Valor1 + 1 Else End If If Target.Cells.Address = "$A$3" Then Target.Cells = Valor1 + 1 Else End If If Target.Cells.Address = "$A$4" Then Target.Cells = Valor1 + 1 Else End If If Target.Cells.Address = "$A$5" Then Target.Cells = Valor1 + 1 Else End If If Target.Cells.Address = "$A$6" Then Target.Cells = Valor1 + 1 Else End If End Sub Vielen Dank für guten Rat Hans aus Peru

Antwort 1 von CaroS

Hallo ,

folgenden Code in das VBA-Projekt der Tabelle kopieren (und bei Bedarf die Messagebox auskommentieren/löschen):

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim zelle As Range, max As Integer

Set zelle = Intersect(Target, Range("A1:A100"))
If Not zelle Is Nothing Then
    max = ActiveSheet.Cells(1, 2).Value + 1
    zelle.Value = max + 1
    MsgBox "Nach Klick auf " & zelle.Address & " wurde dort der Wert " & max & " eingetragen."
End If

End Sub


Wenn in B1 nicht mehr der Wert und die Formel
=MAX(A1:A100)
stehen soll, muss das Maximum im Makro ermittelt werden. Das könnte dann so aussehen, wobei ich von Integer-Werten ausgegangen bin (ggf. anpassen!):

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim zelle As Range, a As Integer, i As Integer, max As Integer

Set zelle = Intersect(Target, Range("A1:A100"))
If Not zelle Is Nothing Then
    max = -32768
    For i = 1 To 100
        a = ActiveSheet.Cells(i, 1).Value
        If a > max Then max = a
    Next i
    zelle.Value = max
    MsgBox "Nach Klick auf " & zelle.Address & " wurde dort der Wert " & max + 1 & " eingetragen."

End If


Schöne Grüße in die Berge!
CaroS

Antwort 2 von JoeKe

Hallo Hans,

oder kürzer:

Option Explicit
Private Sub Worksheet_selectionChange(ByVal Target As Range)
Dim Valor1 As String
Valor1 = Range("B1")
Set Target = Intersect(Target, Range("A1:A100"))
If Target Is Nothing Then Exit Sub
Target = Valor1 + 1
End Sub



Mit der Max-Berechnung im Code:

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set Target = Intersect(Target, Range("A1:A100"))
If Target Is Nothing Then Exit Sub
Target = Application.WorksheetFunction.Max(Range("A1:A100")) + 1
End Sub


MfG

JöKe

Antwort 3 von nighty

hi all :)

dann ich auch noch :))

gruss nighty

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
If Target.Column = 1 And Target.Row > 0 And Target.Row < 111 Then Cells(Target.Row, Target.Column) = Worksheets(1).Range("A1:A100").Find(WorksheetFunction.Subtotal(4, Range("A1:A100"))) + 1
Application.EnableEvents = True
End Sub

Antwort 4 von hans_pe

Herzlichen Dank ihr Helfer in der Nacht. Das war mein erster Versuch in Supportnet. Von Peru aus (7h Zeitverschiebung zu Mitteleuropa) scheint dies besonders interessant zu sein. Wenn man am Abend spät eine Frage eingibt, hat man am andern Morgen früh 3 Antworten (7 Lösungsvorschläge)
Besten Dank und Grüsse aus Peru

Ich möchte kostenlos eine Frage an die Mitglieder stellen:


Ähnliche Themen:


Suche in allen vorhandenen Beiträgen: