AW: 2 Felder vergelichen und ein drittes um 1 erhöhen
17.09.2012 11:38:23
UweD
Hallo
ich hab mal was ähnliches von mir auf deine Bedürfnisse abgeändert.
Bei Änderungen in A1 = Scanfeld startet das Makro
Ich verwende einen Scanner, der parallel zur Tastatur verwendet wird. D.h. du kannst scannen oder per Tastatur eingeben.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1")) Is Nothing Then 'Scanfeld =A1
On Error GoTo Fehler
Application.EnableEvents = False
Dim SP%, c, LA&, JN
SP = 4 'Mitglieder in Salte D / Anzahl in E *** ändern
With Columns(SP)
Set c = .Find(What:=Target.Value, LookIn:=xlValues)
If Not c Is Nothing Then
'bereits vorhanden
Cells(c.Row, SP + 1) = Cells(c.Row, SP + 1) + 1
Else
'ist neu
JN = MsgBox("Neues Mitglied." & Chr(13) & Chr(13) & "Anlegen?", vbYesNo + _
vbQuestion, "Mitgliederverwaltung")
If JN = 6 Then 'neu anlegen
LA = ActiveSheet.Cells(Rows.Count, SP).End(xlUp).Row + 1
Cells(LA, SP) = Target.Value
Cells(LA, SP + 1) = 1
'sortieren
With Me.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("D2:D" & LA _
), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
.SetRange Range("D1:E" & LA)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Else
MsgBox "Nicht angelegt", vbOKOnly + vbExclamation, "Mitgliederverwaltung"
End If
End If
Target.Value = "" 'Scanfeld wieder löschen
Target.Select
End With
End If
Fehler:
If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & " " & Err.Description
Application.EnableEvents = True
End Sub
Gruß UweD
https://www.herber.de/bbs/user/81862.xlsm