AW: Ergänzung
31.03.2015 11:13:11
fcs
Hallo Fritz,
den umgekehrten Weg hatten wir ja schon vor ein paar Tagen, wenn auch in einfacherer Form mit anderen Zellbereichen.
Gruß
Franz
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