AW: Fortlaufende Nummer prüfen und nur einmal vergeben
13.08.2007 22:36:00
chris58
Hallo !
Ja, das ist das richtige, nur leider bin ich nicht fähig das in meine Datei reizukopieren. Ich nehme den Code aus Dok.Ink. und kopiere ihn in meine Datei Dok.Ink. .. doch da geht der Code dann nicht
lg
chris
So hab ich den Code kopiert in Dok.Ink. muß ich noch woanders eine Änderung vornehmen ?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lRow As Long
Dim sSheet As String
Dim iLfd_Nr As Integer
If Target.Column = 2 And Target.Row > 3 And Target.Rows.Count = 1 Then
If Target.Value > WorksheetFunction.Max(Range("B3:B" & Target.Row - 1)) Then
If Application.WorksheetFunction.CountIf(Worksheets _
("Neuwagen-Finanzierung").Range("B3:B1000"), Target.Value) 0 Or _
Application.WorksheetFunction.CountIf(Worksheets _
("Erledigt").Range("B3:B1000"), Target.Value) 0 Then
MsgBox "Die eingetragene laufende Nummer """ & Target.Value & _
""" gibt es bereits - bitte eine neue Nummer eingeben.", _
48, " Hinweis für " & Application.UserName
Target.Value = ""
Cells(Target.Row, 2).Select
Exit Sub
End If
End If
End If
If Not ((Target.Column = 9 Or Target.Column = 10) And _
Target.Row > 3 And Target.Rows.Count = 1) Then GoTo leave_sub
On Error GoTo leave_sub
Application.EnableEvents = False
If IsDate(Target) Then ' Abfrage, ob Datum
sSheet = IIf(Target.Column = 9, "Erledigt", "Neuwagen-Finanzierung")
lRow = Sheets(sSheet).Range("A" & Sheets(sSheet).Rows.Count).End(xlUp).Row + 1
ActiveSheet.Range(Cells(Target.Row, 1), Cells(Target.Row, 10)).Copy
Sheets(sSheet).Cells(lRow, 1).PasteSpecial Paste:=xlPasteValues
If sSheet = "Erledigt" Then
Sheets(sSheet).Cells(lRow, 1).PasteSpecial Paste:=xlPasteFormats
ActiveSheet.Cells(Target.Row, 1).EntireRow.Delete (xlUp)
Sheets(sSheet).Cells(lRow, 11) = Date
MsgBox "Wurde in die Datei [Erledigt] kopiert" & vbCrLf & _
"und in der Datei [Dok.Ink] gelöscht!", _
vbOKOnly + vbInformation, "Erledigen"
Else
Sheets(sSheet).Cells(lRow, 11).Value = Date
MsgBox "Datensatz wurde in Datei [" & sSheet & "] kopiert!", _
vbOKOnly + vbInformation, "Kopieren"
End If
End If
leave_sub:
Application.EnableEvents = True
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("C4:C5000")) Is Nothing Then
Sheets("Quittung").Range("D7").Value = Target.Value
End If
End Sub