mit welchem Makro kann ich aus einer geöffneten Mappe die Mappe "Sicherung.xlsm" öffnen? Die Datei befindet sich im gleichen Ordner wie die Datei, aus der das Makro gestartet wird.
Für Eure Unterstützung vielen Dank im Voraus.
Liebe Grüße
Fritz
Sub OeffnenSicherung()
Dim strPfad As String, strDatei As String
strPfad = ThisWorkbook.Path
strDatei = strPfad & Application.PathSeparator & "Sicherung.xlsm"
If Dir(strDatei) "" Then
Application.EnableEvents = False 'evtl. erforderlich, um Ereignismakros _
in der zu öffnenden Datei zu unterdrücken.
Application.Workbooks.Open Filename:=strDatei
Application.EnableEvents = True 'erforderlich, wenn oben auf False gesetzt
Else
MsgBox "Datei ""Sicherung.xlsm"" nicht gefunden!"
End If
End Sub
Sub OeffnenSicherung()
Dim strPfad As String, strDatei As String
Dim arrRng, intB As Integer
Dim StatusCalc As Long
Dim wkbSicherung As Workbook, wksSicherung As Worksheet
Dim wkbZiel As Workbook, wksZiel As Worksheet
If MsgBox("Gesicherte Daten laden?", _
vbQuestion + vbOKCancel, _
"Laden gesicherte Daten") = vbCancel Then Exit Sub
Set wkbZiel = ThisWorkbook
strPfad = wkbZiel.Path
strDatei = strPfad & Application.PathSeparator & "Sicherung.xlsm"
If Dir(strDatei) "" Then
'Makrobremsen lösen
With Application
.EnableEvents = False
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.StatusBar = "Laden der gesicherten Daten läuft"
End With
'Sicherungsdatei schreibgeschützt öffnen
Set wkbSicherung = Application.Workbooks.Open(Filename:=strDatei, ReadOnly:=True)
'Tabellenblätter abarbeiten
For Each wksZiel In wkbZiel.Worksheets
Select Case wksZiel.Name
Case "Tabelle1", "Tabelle2" 'Diese Tabellen aus Sicherung füllen
Set wksSicherung = wkbSicherung.Worksheets(wksZiel.Name)
'Bereiche festlegen aus denen gesicherte Daten übernommen werden sollen
Select Case wksZiel.Name
Case "Tabelle1"
arrRng = Array("A2:N51")
Case "Tabelle2"
arrRng = Array("A14:A63", "K14:K63", "T14:Y63")
End Select
Case Else
Set wksSicherung = Nothing
End Select
If Not wksSicherung Is Nothing Then
'Werte der Bereiche aus Sicherung übertragen
For intB = LBound(arrRng) To UBound(arrRng)
With wksSicherung
wksZiel.Range(arrRng(intB)).Value = .Range(arrRng(intB)).Value
End With
Next intB
Erase arrRng
End If
Next wksZiel
wkbZiel.Activate
'Sicherungsdatei wieder schliessen
wkbSicherung.Close savechanges:=False 'diese Zeile ggf. weglassen.
'Variablen aufäumen
Set wkbSicherung = Npthing: Set wksSicherung = Nothing
Set wkbZiel = Npthing: Set wksZiel = Nothing
'Makrobremsen zurücksetzen
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = StatusCalc
.StatusBar = False
End With
Else
MsgBox "Datei ""Sicherung.xlsm"" nicht gefunden!"
End If
End Sub