AW: Command Button mit Passwort
07.12.2011 19:49:02
Arthur
Option Explicit
Option Compare Binary 'GROSS-klein Schreibung
Private Sub CommandButton1_Click()
If Application.InputBox("Passwort eingeben", "PasswortBox", "Geheim", , , , , 2) " _
supergeheim" Then
MsgBox "Passwort falsch"
Exit Sub
End If
MsgBox
Public Sub Aufteilen_1()
Dim wksKriterienSheet As Worksheet
Dim wksQuellSheet As Worksheet
Dim rngKriterium As Range
Dim wksNew As Worksheet
Dim wksTMP As Worksheet
Dim lngLastRow As Long
On Error GoTo Fin
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
For Each wksTMP In ThisWorkbook.Worksheets
If wksTMP.Name Like "#*" Then
wksTMP.Delete
End If
Next wksTMP
' Tabellenblatt mit Daten - Name ANPASSEN
Set wksQuellSheet = Worksheets("Necessary prefixes")
Set wksKriterienSheet = Worksheets.Add
wksKriterienSheet.Move After:= _
ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
lngLastRow = wksQuellSheet.Range("B" & Rows.Count).End(xlUp).Row
wksQuellSheet.Range("b1:b" & lngLastRow).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=wksKriterienSheet.Range("b1"), Unique:=True
Set rngKriterium = wksKriterienSheet.Range("b2")
While rngKriterium.Value ""
Set wksNew = Worksheets.Add
wksQuellSheet.Range("A1:N" & lngLastRow).AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=rngKriterium.Offset(-1).Resize(2), _
CopyToRange:=wksNew.Range("A1"), Unique:=True
Columns.AutoFit
wksNew.Name = rngKriterium.Text
rngKriterium.EntireRow.Delete
Set rngKriterium = wksKriterienSheet.Range("b2")
Wend
wksKriterienSheet.Delete
Fin:
With Application
.Goto wksQuellSheet.Range("A1"), True
.ScreenUpdating = True
.DisplayAlerts = True
End With
Set wksKriterienSheet = Nothing
Set wksQuellSheet = Nothing
Set rngKriterium = Nothing
Set wksNew = Nothing
End Sub
End Sub
Irgendwie geht das nicht, was mach ich falsch?