AW: Makros per Makro löschen
06.08.2009 22:30:09
Universal
Hi zusammen,
ich schulde euch / Daniel noch eine Antwort ... Du hast Recht sich selbst löschender Code ist zu "instabil". Ich habe nun das Tool etwas abgeändert. Es funktioniert nun einwandfrei ... Das Makro ist flexibel gestaltet und von mir kommentiert ...
Vielleicht kann es jemand anderes auch gebrauchen ...
Sub Password()
Application.ScreenUpdating = False
'define variables:
Dim iSheets As Integer
Dim aSheets3 As Integer
Dim cSheets As Integer
Dim Alert As Integer
Dim Number As Integer ' -> one password character
Dim PLength As Integer ' -> password length
Dim Password As String ' -> full password value
Dim Selection As String
Dim PW As String
Selection = "B1" ' -> selection cell for choosing whether the sheet should be copied or not
PW = "123" ' -> default password for the original document
OriginBook = ActiveWorkbook.Name ' -> original workbook`s name defined as a variable
aSheets = Workbooks(OriginBook).Sheets.Count ' -> amount of sheets in original workbook _
is defined in this variable
'check whether at least one sheet is selected
For iSheets = 1 To aSheets
If Workbooks(OriginBook).Sheets(iSheets).Range(Selection) "x" Then
Alert = 1 ' -> if no sheet is selected activate the "alert"
Else
GoTo GoAhead ' -> if at least one sheet is selected go to paragraph "GoAhead"
End If
Next iSheets
If Alert = 1 Then GoTo Error ' -> if "alert" is activated go to paragraph "Error" and exit
GoAhead:
'unprotect all selected sheets
For iSheets = 1 To aSheets
If Workbooks(OriginBook).Sheets(iSheets).Range(Selection) = "x" Then
Workbooks(OriginBook).Sheets(iSheets).Unprotect (PW)
End If
Next iSheets
Application.Workbooks.Add ' -> creat a new Excel workbook
NewBook = ActiveWorkbook.Name ' -> original workbook`s name defined as a variable
aSheets2 = Workbooks(NewBook).Sheets.Count ' -> amount of sheets in new workbook is defined _
in this variable
'copy all selected sheets into the new workbook
cSheets = 1
For iSheets = 1 To aSheets
If Workbooks(OriginBook).Sheets(iSheets).Range(Selection) = "x" Then
Workbooks(OriginBook).Sheets(iSheets).Copy After:=Workbooks(NewBook).Sheets(2 + cSheets) _
cSheets = cSheets + 1
End If
Next iSheets
'delete all existing sheets from new workbook
Application.DisplayAlerts = False
For iSheets = 1 To aSheets2
Workbooks(NewBook).Sheets(1).Delete
Next iSheets
Application.DisplayAlerts = True
'generate random password
Randomize Timer
For PLength = 1 To 10 ' -> define password length
Number = Int((90 - 48 + 1) * Rnd + 48) ' -> generate random value
Do While Number > 55 And Number if random number is invalid ...
Number = Int((90 - 48 + 1) * Rnd + 48) ' -> generate new random value
Loop ' -> "Do While ... Loop" runs till random value _
is correct
Password = Password + Chr(Number) ' -> creating password
Next PLength ' -> "For ... Next" runs till PLength = 10
'delete the command button (if necessary) and protect all existing sheets in new workbook
aSheets3 = Workbooks(NewBook).Sheets.Count ' -> amount of sheets in new workbook is defined _
in this variable
For iSheets = 1 To aSheets3
With Workbooks(NewBook).Sheets(iSheets)
On Error Resume Next ' -> if command button not available jump over _
the next line
.Shapes("cmdFinalize").Delete ' -> delete command button (if necessary)
.Protect Password:=Password ' -> use the generated password to protect the sheet
.EnableSelection = xlNoSelection
End With
Next iSheets
Workbooks(NewBook).Protect Password:=Password ' -> use the generated password to protect _
the workbook
Workbooks(NewBook).Sheets(1).Select ' -> select the first sheet of the new workbook
On Error GoTo Error2
Application.Dialogs(xlDialogSaveAs).Show ' -> open the "Save As" dialog for the new workbook
Workbooks(OriginBook).Close SaveChanges:=False ' -> close the original workbook without _
saving any changes
Exit Sub
Error:
MsgBox "Please select at least one sheet for finalizing the document.", vbCritical, "Error"
Exit Sub
Error2:
MsgBox "Error while saving the file.", vbCritical, "Error"
Application.ScreenUpdating = True
End Sub