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):
Wenn in B1 nicht mehr der Wert und die Formel
Schöne Grüße in die Berge!
CaroS
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
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
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
Besten Dank und Grüsse aus Peru