Daten von per Makro geöffneten Datei kopieren
02.02.2015 23:36:21
per
Ich habe ein Problem bei einem bestehenden Makro zum Updaten einer Excel-Datei. Ich habe diesen Updater nicht selbst geschrieben. Auf jeden Fall brauche ich eine Funktion, die von der für das Update bestimmten Datei ein paar Daten (Sheets("Systemblatt").Range ("O2-O8")) in die Zieldatei kopiert. Ich habe das mal unten mit kursiv fett hereingeschrieben, es kommt aber immer ein Fehler. Weiss da jemand weiter, oder was der Fehler ist?
LG Elias
Private Sub CommandButton1_Click()
Dim wkbUpdate As Workbook
Dim wkbAlt As Workbook, wksData As Worksheet
Dim varAuswahl As Variant, arrSheet() As String, intI As Integer
On Error GoTo Beenden
'Dateiauswahldialog anzeigen
varAuswahl = Application.GetOpenFilename( _
Filefilter:="Excel(*.xls;*.xlsx;*.xlsm;*.xlsb),*.xls;*.xlsx;*.xlsm;*.xlsb", _
Title:="Bitte bestehende Datei auswählen")
If varAuswahl = False Then
MsgBox "Die Aktualisierung der bestehnden Datei wurde abgebrochen! " & vbLf _
& "Bitte Update nochmals starten!", _
vbInformation + vbOKOnly, "U P D A T E"
GoTo Beenden
End If
'Main-Datei-Objekte setzen
Set wkbUpdate = ActiveWorkbook
Application.ScreenUpdating = False
'alte Datei schreibgeschützt öffnen
Set wkbAlt = Application.Workbooks.Open(Filename:=varAuswahl, ReadOnly:=True)
With wkbAlt
'Sicherungskopie der alten Datei erstellen
.SaveCopyAs Filename:=.Path & "\" _
& "Update-Sicherheitskopie_" & Format(Now, "YYYY-MM-DD hhmmss") & .Name
i = Sheets.Count
For Z = 1 To i
Sheets(Z).Unprotect
Next Z
.Sheets(6).Range("O2-O8").Select
Selection.Copy
wkbUpdate.Sheets("Systemblatt").Range ("O2-O8")
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
If .Sheets.Count >= 8 Then
'Namen der zu kopierende Blätter in Array sammeln
ReDim arrSheet(8 To .Sheets.Count)
For intI = 8 To .Sheets.Count
arrSheet(intI) = .Sheets(intI).Name
Next
.Sheets(arrSheet).Copy after:=wkbUpdate.Sheets(wkbUpdate.Sheets.Count)
Erase arrSheet
Else
MsgBox "Keine Datentabellen in Datei vorhanden"
End If
'Daten-Datei wieder schließen
.Close savechanges:=False
End With
Set wkbAlt = Nothing
wkbUpdate.Activate
Application.ScreenUpdating = True
With Application.FileDialog(msoFileDialogSaveAs)
.Title = "Bitte Update-Datei unter neuem Namen speichern"
.InitialFileName = "AktualisierteDatei"
.FilterIndex = 2 '1= xlsx (Standard), 2 = xlsm
If .Show = -1 Then
wkbUpdate.SaveAs Filename:=.SelectedItems(1), addtomru:=True
MsgBox "Datei wurde erfolgreich aktualisiert", _
vbInformation + vbOKOnly, "U P D A T E"
ActiveWorkbook.Sheets("Ansichtspinne").Activate
Sheets("Ansichtspinne").Unprotect
Sheets("Ansichtspinne").Range("A1").Select
Sheets("Ansichtspinne").Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
True
Me.Hide
For ii = 8 To Sheets.Count
Sheets(ii).Cells.Replace What:=" ", Replacement:="", LookAt:=xlWhole
Next ii
Else
MsgBox "Speichern der aktualisierten Datei wurde abgebrochen!"
End If
End With
Beenden:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
If Not wkbAlt Is Nothing Then wkbAlt.Close savechanges:=False
End Select
End With
Application.ScreenUpdating = True
End Sub