AW: schau mal diesen beitrag an... Gruß
16.06.2010 12:26:39
Ernst
Hallo Robert !
dein Linkverweis ist sehr hilfreich vorallem die datei 69937.xls
Ich habe allerdings Probleme das in meine Datei zu integrieren.
bin so vorgegangen modul hinzugefügt Makros hineinkopiert.
makrocode in Tabelle 1 integriert.aber es tut sich nichts ?
Option Explicit
Const sPass As String = "xxx" 'Passwort anpassen
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngBereich As Range, tmpBereich As Range
Set rngBereich = Range("B2", Cells(Rows.Count, 2).End(xlUp))
For Each rngBereich In rngBereich
If rngBereich "" Then
If tmpBereich Is Nothing Then
Set tmpBereich = rngBereich
Else
Set tmpBereich = Union(tmpBereich, rngBereich)
End If
End If
Next rngBereich
If Not tmpBereich Is Nothing Then
ActiveSheet.Unprotect sPass
On Error Resume Next
tmpBereich.Locked = True
ActiveSheet.Protection.AllowEditRanges(1).Delete
ActiveSheet.Protection.AllowEditRanges.Add Title:="Bereich1", Range:=tmpBereich, Password:= _
sPass
ActiveSheet.Protect sPass
End If
Dim iSpalte As Variant ' die Eingabe- und die zu vergleichenden Spalten
Dim iIndex As Integer ' Index für den Spalten-Array
If Target.Count > 1 Then Exit Sub ' mehr als eine Zelle markiert ?
If Target.Value = "" Then Exit Sub ' ist die Zelle gefüllt ?
' B C I J P Q
iSpalte = Array(2, 3, 9, 10, 16, 17) ' die Spalten-Nummern als Array
If Target.Column = 2 Or Target.Column = 3 Or _
Target.Column = 9 Or Target.Column = 10 Or _
Target.Column = 16 Or Target.Column = 17 Then ' eine gültige Eingabe-Spalte ?
For iIndex = 0 To UBound(iSpalte) ' alle Spalten abarbeiten/vergleichen
If Target.Column = iSpalte(iIndex) Then ' ist es die Eingabespalte ?
If Application.WorksheetFunction.CountIf(Columns(Target.Column), _
Target.Value) > 1 Then ' zählen in der Eingabespalte
If MsgBox("die Eingabe """ & Target.Value & """ gibt es " & _
"in der Spalte """ & Chr(Asc("@") + iSpalte(iIndex)) & """ bereits." _
& Chr(10) & "Wollen Sie den Eintrag trotzdem übernehmen?", _
vbYesNo + vbQuestion, " nur zur Sicherheit.") = vbYes Then
Exit Sub
Else
Target.Value = "" ' die Eingabe löschen
Cells(Target.Row, Target.Column).Select ' Cursor auf die Eingabezelle
Exit For
End If
End If
Else ' es ist NICHT die Eingabspalte !
If Application.WorksheetFunction.CountIf(Columns(iSpalte(iIndex)), _
Target.Value) > 0 Then ' zählen in den NICHT Eingabespalten
If MsgBox("die Eingabe """ & Target.Value & """ gibt es " & _
"in der Spalte """ & Chr(Asc("@") + iSpalte(iIndex)) & """ bereits." _
& Chr(10) & "Wollen Sie den Eintrag trotzdem übernehmen?", _
vbYesNo + vbQuestion, " nur zur Sicherheit.") = vbYes Then
Exit Sub
Else
Target.Value = "" ' die Eingabe löschen
Cells(Target.Row, Target.Column).Select ' Cursor auf die Eingabezelle
Exit For
End If
End If
End If
Next iIndex
End If
End Sub
Private Sub ComboBox1_Change()
End Sub
Private Sub CommandButton1_Click()
Application.Dialogs(xlDialogPrint).Show
End Sub
Private Sub CommandButton2_Click()
speicherneinblendenzurück
End Sub
Private Sub CommandButton3_Click()
speichernzurück
End Sub
Private Sub CommandButton4_Click()
seite1drucken
End Sub
Private Sub CommandButton5_Click()
seite2drucken
End Sub
Private Sub CommandButton6_Click()
seite4drucken
End Sub
Private Sub CommandButton7_Click()
speicherneinblendenzurück
End Sub
Private Sub CommandButton8_Click()
seite1drucken
End Sub
Private Sub ListBox1_Click()
seite1drucken
End Sub
Private Sub SpinButton1_Change()
End Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim b As Variant, c As Integer, objZelle As Range
b = TextBox1.Value
c = Len(b)
x = y 'ist wohl überflüssig
If KeyCode = 13 Then
If c > 0 Then
On Error GoTo ende
Application.EnableEvents = False
'ActiveCell.Select
'Me.Unprotect
Set objZelle = rngSuchbereich.Find(What:=b, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False)
If objZelle Is Nothing Then
MsgBox "Wagen Nr. nicht vorhanden !!"
'TextBox1.Value = ""
Else
Me.Unprotect
'ggf. letzte Markierung entfernen
If Not LastAuswahl Is Nothing Then
LastAuswahl.Interior.ColorIndex = oldFarbe
Set LastAuswahl = Nothing
End If
objZelle.Activate
Set wksLast = Me 'Tabellenblatt merken
Set LastAuswahl = objZelle 'Zelle merken
oldFarbe = objZelle.Interior.ColorIndex 'Farbe Merken
objZelle.Interior.ColorIndex = 45
'Range("P104").Value = b
'TextBox1.Value = ""
Me.Protect
End If
Application.EnableEvents = True
End If
End If
Exit Sub
ende:
Application.EnableEvents = True
MsgBox Err.Number & vnld & Err.Description
Me.Protect
End Sub
Function rngSuchbereich() As Range
Dim Cell As Range
For Each Cell In Range("A1:AA113")
If Cell.Locked = False Then
If rngSuchbereich Is Nothing Then
Set rngSuchbereich = Cell
Else
Set rngSuchbereich = Union(rngSuchbereich, Cell)
End If
End If
Next
End Function
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'ggf Farbe der letzten Auswahl zurücksetzen beim Wechsel der Zellen Auswahl
If Not LastAuswahl Is Nothing Then
If Target.Address LastAuswahl.Address Then
Me.Unprotect
LastAuswahl.Interior.ColorIndex = oldFarbe
Set LastAuswahl = Nothing
Me.Protect
End If
End If
End Sub
Private Sub Worksheet_Deactivate()
'ggf Farbe der letzten Auswahl zurücksetzen beim Verlassen des Tabellenblatts
If Not LastAuswahl Is Nothing Then
Me.Unprotect
LastAuswahl.Interior.ColorIndex = oldFarbe
Set LastAuswahl = Nothing
Me.Protect
End If
End Sub
lg.Ernst