AW: Blattschutz lautet wie?!!!
23.12.2010 12:01:00
Heinz
Sorry Robert
Pw = "vetro"
Danke
Gruß
Heinz
Habe mal die ganzen Makros eingestellt.
Option Explicit
'Suchen
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
ActiveSheet.Unprotect Password:="vetro"
Dim WkSh As Worksheet ' die Variable nimmt ein Excel-Sheet auf
Dim lZeile As Long ' Lauf-Variable für die Zeile in Schleife
Dim lSpalte As Long ' Lauf-Variable für die Spalte in Schleife
Dim bolGefunden As Boolean ' Status für Suchbegriff gefunden
Dim f As Integer
Dim LetzteZeile As Integer ' damit wir wissen bis wohin eigentlich
Dim Suchstring As String
Dim s As String
ListBox1.Clear ' Löscht den alten Suchantrag
If TextBox20.Text = "" Then
Call MsgZeit2
Exit Sub
End If
Set WkSh = Worksheets("Mitarbeiterblatt") 'Zuordnung der Adressens-Tabelle
WkSh.Unprotect Password:="vetro"
LetzteZeile = WkSh.UsedRange.SpecialCells(xlCellTypeLastCell).Row 'Excel sagt mir bis wohin
'einen Suchstring erzeugen aus den Eingaben
Suchstring = Trim(UCase(TextBox20.Text)) '& Trim(UCase(TextBox2.Text))
bolGefunden = False
'Name + Nachname finden in Spalten A und B finden
For lZeile = 2 To LetzteZeile ' Schleife zum Suchen
'Vergleichsstring erzeugen aus den Zellen
s = UCase(Trim(WkSh.Cells(lZeile, 1))) & UCase(Trim(WkSh.Cells(lZeile, 2)))
If Suchstring = s Then
bolGefunden = True
Exit For ' raus wenn gefunden - wenn absolut identisch
End If
Next lZeile
If bolGefunden = True Then GoTo DatenEinlesen
'Name/Teilname finden in Spalten A und B finden
For lZeile = 2 To LetzteZeile ' Schleife zum Suchen
'Vergleichsstring erzeugen aus den Zellen
s = UCase(Trim(WkSh.Cells(lZeile, 1))) & UCase(Trim(WkSh.Cells(lZeile, 2)))
If Left(s, Len(Suchstring)) = Suchstring Then
bolGefunden = True
Exit For ' raus wenn ähnlich (nur Nachname z. B.
End If
Next lZeile
If bolGefunden = False Then 'keine genaue Übereinstimmung gefunden
GoTo AlleZellen
End If
DatenEinlesen:
Me.TextBox1 = WkSh.Cells(lZeile, 1).Value 'Spalte A Familienname
Me.TextBox2 = WkSh.Cells(lZeile, 2).Value 'Spalte B Vorname
Me.TextBox3 = WkSh.Cells(lZeile, 3).Value 'Spalte C Straße
Me.TextBox4 = WkSh.Cells(lZeile, 4).Value 'Spalte E Wohnort
Me.TextBox5 = WkSh.Cells(lZeile, 5).Value 'Spalte D PLZ
Me.TextBox6 = WkSh.Cells(lZeile, 6).Value 'Spalte F Tel.
Me.TextBox7 = WkSh.Cells(lZeile, 7).Value 'Spalte G Handy
Me.TextBox8 = WkSh.Cells(lZeile, 8).Value 'Spalte H Emailadresse
Me.TextBox9 = WkSh.Cells(lZeile, 9).Value 'Spalte I Personalnummer
If bolGefunden = False Then GoTo Ende
AlleZellen:
'Alle Zellen in den Spalten 1 bis 8 (A bis H) durchsuchen
For lZeile = 1 To LetzteZeile
For lSpalte = 1 To 9
If Len(TextBox20.Text) "" Then
ActiveSheet.Unprotect Password:="vetro"
Worksheets.Add
Range("A2").Value = "Familienname:"
Range("B2").Value = Me.TextBox1.Value
Range("A3").Value = "Vorname:"
Range("B3").Value = Me.TextBox2.Value
Range("A4").Value = "Straße:"
Range("B4").Value = Me.TextBox3.Value
Range("A5").Value = "Wohnort:"
Range("B5").Value = Me.TextBox4.Value
Range("A6").Value = "PLZ:"
Range("B6").Value = Me.TextBox5.Value
Range("A7").Value = "Telefon:"
Range("B7").Value = Me.TextBox6.Value
Range("A8").Value = "Handy"
Range("B8").Value = Me.TextBox7.Value
Range("A9").Value = "Emailadresse:"
Range("B9").Value = Me.TextBox8.Value
Cells.Select
With Selection.Font
.Name = "Arial"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Columns("A:A").Columns.AutoFit
Columns("B:B").Columns.AutoFit
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A1:B1").Select
Selection.Font.Bold = True
Application.DisplayAlerts = False
With ActiveSheet
.PrintOut
.Delete
End With
Application.DisplayAlerts = False
Application.ScreenUpdating = True
ActiveSheet.Protect Password:="vetro", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True
End If
End Sub
'Neue Einträge hinzufügen
Private Sub CommandButton6_Click()
Application.ScreenUpdating = False
ActiveSheet.Unprotect Password:="vetro"
Dim lngRow As Long
If TextBox1 = "" Then
Call MsgZeit4
'MsgBox "Sie haben keinen Eintrag gewählt"
Exit Sub
End If
Worksheets("Mitarbeiterblatt").Unprotect Password:="vetro"
With Worksheets("Mitarbeiterblatt")
lngRow = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
ActiveSheet.Unprotect Password:="vetro"
.Cells(lngRow, 1) = TextBox1 'Familienname
.Cells(lngRow, 2) = TextBox2 'Vorname
.Cells(lngRow, 3) = TextBox3 'Straße
.Cells(lngRow, 4) = TextBox4 ' Wohnort
.Cells(lngRow, 5) = TextBox5 ' PLZ
.Cells(lngRow, 6) = TextBox6 ' Tel.Nr.
.Cells(lngRow, 7) = TextBox7 ' Handy Nr.
.Cells(lngRow, 8) = TextBox8 ' Emailadresse
.Cells(lngRow, 9) = TextBox9 ' Personalnummer
End With
Call MsgZeit
Worksheets("Mitarbeiterblatt").Protect Password:="vetro"
'MsgBox "Die Einträge wurden gespeichert"
Unload Me
'Neu Blattschutz
ActiveSheet.Protect Password:="vetro", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton8_Click()
' ändern
Dim WkSh As Worksheet
Dim lZeile As Long
Dim iIndx As Integer
Set WkSh = Worksheets("Mitarbeiterblatt") 'Zuordnung der Adressen-Tabelle
WkSh.Unprotect
If TextBox1 = "" Then
Call MsgZeit4
'MsgBox "Sie haben keinen Eintrag gewählt"
Exit Sub
End If
If Me.ListBox1.ListIndex = -1 Then
MsgBox "Sie müssen einen Namen aus der Liste anwählen", vbInformation
Exit Sub
End If
lZeile = Me.ListBox1.List(Me.ListBox1.ListIndex, 3)
With WkSh
For iIndx = 1 To 8 '17
.Cells(lZeile, iIndx).Value = Controls("TextBox" & iIndx).Value
If iIndx UCase(Me.TextBox20.Value) Then _
Me.TextBox20.Value = UCase(Mid(Me.TextBox20.Value, 1, 1)) & _
Mid(Me.TextBox20.Value, 2, Len(Me.TextBox20.Value) - 1)
End Sub
Private Sub cmdSuche_Click()
' Dann ist das Code schreiben einfacher, die Variable nimmt ein Excel-Sheet auf
Dim WkSh As Worksheet
Dim lZeile As Long ' Lauf-Variable für die Schleife
Dim LetzteZeile As Integer ' damit wir wissen bis wohin eigentlich
Set WkSh = Worksheets("Mitarbeiterblatt") 'Zuordnung der Adressen-Tabelle
' Excel sagt mir bis wohin
LetzteZeile = WkSh.UsedRange.SpecialCells(xlCellTypeLastCell).Row
For lZeile = 2 To LetzteZeile ' Schleife zum Suchen
If Trim(WkSh.Cells(lZeile, 1)) = Trim(TextBox1.Text) Then Exit For ' raus wenn gefunden
' Trim, damit nicht aus Versehen irgendwer Leerzeichen eingegeben hat ...
' ,1 .. 1te Spalte = A
Next lZeile
If lZeile > LetzteZeile Then ' es wurde nichts gefunden
MsgBox ("nicht gefunden"), _
48, " Hinweis für " & Application.UserName
Exit Sub
End If
Me.TextBox1 = WkSh.Cells(lZeile, 1).Value 'Spalte A=Fam.Name
Me.TextBox2 = WkSh.Cells(lZeile, 2).Value 'Spalte B=Vorname
Me.TextBox3 = WkSh.Cells(lZeile, 3).Value 'Spalte C=Straße
Me.TextBox4 = WkSh.Cells(lZeile, 4).Value 'Spalte D=Wohnort
Me.TextBox5 = WkSh.Cells(lZeile, 5).Value 'Spalte E=PLZ
Me.TextBox6 = WkSh.Cells(lZeile, 6).Value 'Spalte F=Tel.
Me.TextBox7 = WkSh.Cells(lZeile, 7).Value 'Spalte G=Handy
Me.TextBox8 = WkSh.Cells(lZeile, 8).Value 'Spalte H=Emailadresse
Me.TextBox9 = WkSh.Cells(lZeile, 9).Value 'Spalte I=Personalnummer
End Sub
' löschen
Private Sub CommandButton7_Click()
Application.ScreenUpdating = False
Dim WkSh As Worksheet
Dim lZeile As Long
Dim iIndx As Integer
Set WkSh = Worksheets("Mitarbeiterblatt") 'Zuordnung der Adressen-Tabelle
WkSh.Unprotect Password:="vetro"
If TextBox1 = "" Then 'Exit Sub
MsgBox "Es wurde kein Name ausgewählt", vbInformation
Exit Sub
End If
If Me.ListBox1.ListIndex = -1 Then
MsgBox "Sie müssen einen Namen aus der Liste anwählen", vbInformation
Exit Sub
End If
lZeile = Me.ListBox1.List(Me.ListBox1.ListIndex, 3)
If MsgBox("Wollen Sie den Eintrag """ & WkSh.Cells(lZeile, 1).Value & _
" " & WkSh.Cells(lZeile, 2).Value & """ wirklich löschen?", _
vbYesNo + vbQuestion, " Löschabfrage") = vbYes Then
WkSh.Rows(lZeile).Delete 'Shift:=xlUp
End If
For iIndx = 1 To 9
Controls("TextBox" & iIndx).Value = ""
Next iIndx
Me.ListBox1.Clear
Me.TextBox20.SetFocus
ActiveSheet.Protect Password:="vetro", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True
Application.ScreenUpdating = True
End Sub
Private Sub UserForm_Click()
End Sub