Schließen Quelldatei nach Load Befehl
21.08.2019 10:49:22
Markus
Sub Load()
'Auto-Aktualisierung und Screenupdates auschalten
Application.AutoRecover.Enabled = False
Application.ScreenUpdating = False
'Passwortabfrage zur Bedienung des Buttons
Dim strKey As String
strKey = InputBox(prompt:="Bitte geben Sie das Passwort ein:", Title:="Passworteingabe")
If strKey "Laborlogistik" Then
MsgBox prompt:="Das Passwort ist nicht korrekt.", Buttons:=vbOKOnly, Title:="Fehler"
Exit Sub
Else
End If
Dim WBZiel As Workbook, ExportDatei As Variant
Dim WBQuelle As Workbook, WSZiel As Worksheet
Dim lZeile As Long
On Error GoTo Fehler
Set WBZiel = ThisWorkbook
'Blattschutz von Ergebnisdatei aufheben
Dim shKey As String 'Password für Blattschutz (alle Blätter gleich!!)
shKey = "Laborlogistik"
'alle Sheets durchgehen und Blattschutz aufheben
Dim wsCounter As Worksheet
For Each wsCounter In WBZiel.Worksheets
wsCounter.Unprotect shKey
Next
'Spalten in Ergebnisdatei(Stammdaten) leeren
Sheet5.Range("A2:AD1000").Clear
'DateiÖffnen Dialog anbieten
ExportDatei = Application.GetOpenFilename()
'öffnen der ausgewählten Datei
Set WBQuelle = Workbooks.Open(ExportDatei)
'Blattschutz aller Tabellenblätter der Quelldatei aufheben
For Each wsCounter In WBQuelle.Worksheets
wsCounter.Unprotect shKey
Next
'kopieren des Blattinhaltes und Schließen der Quell-Datei
With WBQuelle
.Sheets("Chemikalien").Range("A5:ad5000").SpecialCells(xlCellTypeConstants).Copy WBZiel. _
Sheets("Stammdaten").Range("A" & WBZiel.Sheets("Stammdaten").Cells(Rows.Count, 1).End(xlUp).row + 1)
.Sheets("Labormaterialien").Range("A5:ad1000").SpecialCells(xlCellTypeConstants).Copy _
WBZiel.Sheets("Stammdaten").Range("A" & WBZiel.Sheets("Stammdaten").Cells(Rows.Count, 1).End(xlUp).row + 1)
End With
'Schließen der ausgewählten Datei
Workbooks("Stammdatenblatt.xlsm").Close SaveChanges:=False
'Blattschutz für Ergebnisdatei wiederherstellen
For Each wsCounter In WBZiel.Worksheets
wsCounter.Protect shKey, True, True, True
Next
'Nach Ausführung wieder in das erste Tabellenblatt springen
Sheet1.Activate
Application.ScreenUpdating = True
Application.AutoRecover.Enabled = True
Fehler:
Exit Sub
End Sub
Anzeige