AW: Noch eine Frage (Passwortschutz)
30.04.2021 12:07:40
fcs
Hallo Snaik,
ich hab das Makro prcDatenUebertragen angepasst, sodass nach dem Öffnen der Vorlage der Blattschutz für alle Blätter in die Daten übertragen werden aufgehoben wird.
Vor dem Speichern/Schliessen wird der Blattschutz wieder aktiviert.
Im Code musst du das Kennwort für den Blattschutz anpassen!
LG
Franz
Sub prcDatenUebertragen()
Dim wkbQuelle As Workbook
Dim wkbVorlage As Workbook
Dim arrZellen
Dim varWert
Dim strPfadNeu As String, strNameNeu As String
Dim strVorlage As String
Dim colSheets As New Collection, iCol As Integer
Dim zeiZelle As Long
Dim lngZei As Long
Const strPW As String = "beispielpasswort" 'Kennwort für Blattschutz 'ggf. anpassen
On Error GoTo Fehler
With tabSteuerung
'Werte einlesen und Variablen zuweisen
'Pfad+Name der Vorlage-Datei
strVorlage = .Cells(mZei_T - 1, 12)
'Verzeichnis in dem die neuu erstellten Dateien gespeichert werden sollen
strPfadNeu = .Cells(mZei_T - 1, 13)
'letzte Zeile im Zellbereich mit den Zellzuweisungen
zeiZelle = .Cells(.Rows.Count, 1).End(xlUp).Row
'Zellbereich mit den Zellzuweisungen in ein Datenarray einlesen - beschleunigt die Makro-Ausführung
arrZellen = .Range(.Cells(mZei_T + 1, 1), .Cells(zeiZelle, 10)).Value2
'Namen der Blätter in der Vorlage, in die Werte eingetragen werden sollen, in einer Collection sammeln
For zeiZelle = LBound(arrZellen, 1) To UBound(arrZellen, 1)
colSheets.Add arrZellen(zeiZelle, 7), Key:=arrZellen(zeiZelle, 7)
Next
'ausgewählte Dateien abarbeiten
For lngZei = mZei_T + 1 To .Cells(.Rows.Count, 12).End(xlUp).Row
'Quelle mit Daten schreibgeschützt öffnen
Application.EnableEvents = False
Set wkbQuelle = Application.Workbooks.Open(Filename:=.Cells(lngZei, 12).Text, ReadOnly:=True)
Application.EnableEvents = True
'Berechnung des Dateinamens der neuen Datei
With wkbQuelle.Worksheets("NK_Fertigungskalkulation") 'Blattname ggff. anpassen
strNameNeu = "KdNr " & .Cells(5, 4).Text & " - ProdNr " & .Cells(5, 2).Text & ".xlsx"
End With
'Vorlage scheibgeschütz öffnen
Set wkbVorlage = Application.Workbooks.Open(Filename:=strVorlage, ReadOnly:=True)
'Vorlage unter neuem Namen speichern und schliessen
wkbVorlage.SaveAs Filename:=strPfadNeu & strNameNeu, FileFormat:=51
'Schutz der Blätter aufheben
With wkbVorlage
For iCol = 1 To colSheets.Count
.Worksheets(colSheets(iCol)).Unprotect Password:=strPW
Next
End With
'Zellzuweisungen abarbeiten
For zeiZelle = LBound(arrZellen, 1) To UBound(arrZellen, 1)
'Wert in Zelle in der Quelle in Variable
varWert = wkbQuelle.Worksheets(arrZellen(zeiZelle, 1)).Cells(arrZellen(zeiZelle, 2), arrZellen(zeiZelle, 3)).Value
'Prüfen, ob Zelle einen Fehlerwert enthält
If IsError(varWert) Then
'angezeigten Text der Zelle in Variable einlesen
varWert = wkbQuelle.Worksheets(arrZellen(zeiZelle, 1)).Cells(arrZellen(zeiZelle, 2), arrZellen(zeiZelle, 3)).Text
'Prüfen, ob Zelle leer ist
ElseIf IsEmpty(varWert) Then
varWert = ""
End If
'Wert in Vorlage eintragen
wkbVorlage.Worksheets(arrZellen(zeiZelle, 7)).Cells(arrZellen(zeiZelle, 8), arrZellen(zeiZelle, 9)).Value = varWert
Next zeiZelle
'Schutz der Blätter wieder aktivieren
With wkbVorlage
For iCol = 1 To colSheets.Count
.Worksheets(colSheets(iCol)).Protect Password:=strPW
Next
End With
'Neue Datei speichern und schliessen
wkbVorlage.Close savechanges:=True
'neuen Namen in Blatt "Steuerung" eintragen
.Cells(lngZei, 13).Value = strNameNeu
'Quelldatei schliessen
wkbQuelle.Close savechanges:=False
Next lngZei
End With
Fehler:
With Err
Select Case .Number
Case 0 'alles ok
Case 457
Resume Next
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, vbOKOnly, "Fehler - Makro: prcDatenUebertragen"
End Select
End With
End Sub