AW: Makro endet immer auf dem Desktop
15.05.2013 11:51:32
Klaus
Hi Toumas,
vorab enschuldige: Die Lösung ist vielleicht ein wenig Overkill für dein VBA-Level. Dafür erledigt sie ihre Aufgabe aber absolut sauber.
Ich habe versucht, möglichst ausführlich zu kommentieren. Deinen Originalcode habe ich größtenteils auskommentiert statt ihn zu löschen, damit du leicher vergleichen und nachvollziehen kannst. Im Finalen einsatz solltest du die auskommentierten Codezeilen der übersichtlichkeit halber endgültig löschen.
Bei Fragen: fragen!
Sub Kopieren1()
'** hier die Sheet-Namen auf deine anpassen
Const sSheetNewFile As String = "aaaaaa"
Const sSheetOldFile As String = "BBBBB"
Const sPassword As String = "123"
Dim wkbOld As Workbook
Dim wkbNew As Workbook
Set wkbOld = ActiveWorkbook
'** altes Workbook merken
'ERSETZT Workbooks.Open Filename:= "\\xxx\xxx\xxx\xxxxx\xxxx\xxx\xxxxxxx\yyyyyyyyyy.xlsx"
Call FileCheckOpen("\\xxx\xxx\xxx\xxxxx\xxxx\xxx\xxxxxxx", "yyyyyyyyyy.xlsx")
'** wenn das workbook bereits offen ist, gibts ne Fehlermeldung!
'** die Sub "FileCheckOpen" verhindert eben diese
Set wkbNew = ActiveWorkbook
'** neues Workbook merken (ist aktiv, da grad geöffnet!)
'ERSETZE Sheets("aaaaaa").Activate
If Not WksSheetExists(sSheetNewFile) Then
'** Wenn es das sheet nicht gibt, dann gibts ne Fehlermeldung!
'** Die Sub "wksSheetsExists" verhindert diese
MsgBox ("falsches Sheet!")
'** neues Workbook wieder schließen und Sub beenden
wkbNew.Close
Exit Sub
End If
With wkbNew.Sheets(sSheetNewFile)
'Windows("MeineDatei.xlsm").Activate
'Sheets("BBBBB").Select
'** statt "activate" und "select" lieber direkt referenzieren
.Unprotect sPassword
.Range("B9:Q31").Copy
End With
With wkbOld.Sheets(sSheetOldFile)
'Windows("MeineDatei.xlsm").Activate
'Sheets("BBBBB").Select
'** statt "activate" und "select" lieber direkt referenzieren
.Unprotect sPassword
.Range("B9").PasteSpecial
Application.CutCopyMode = False
.Protect sPassword
End With
'Application.DisplayAlerts = False
'ActiveSheet.Protect "123"
'** kein Grund den Schutz wieder zu setzen - du schließt ja ohne zu speichern!
'ERSETZT ActiveWindow.Close
wkbNew.Close True
'** wkbNew haben wir uns oben gemerkt, können wir hier also direkt schließen
'Application.DisplayAlerts = True
'** auf die "gefählichen" DisplayAlerts verzichten wir auch, da CLOSE mit
'** dem Zusatz "TRUE" ohne Rückfrage ausgeführt wird.
End Sub
Sub FileCheckOpen(sPath As String, sFile As String)
'Prüft, ob es eine Datei schon offen ist
'Wenn ja, wird sie aktiviert. Wenn nein, geöffnet.
sPath = sPath & "/" & sFile
If WkbExists(sFile) = False Then
If Dir(sPath) = "" Then
MsgBox "File " & sPath & " not found!"
Else
Workbooks.Open sPath, UpdateLinks:=False
End If
Else
Workbooks(sFile).Activate
End If
End Sub
Function WkbExists(sFile As String) As Boolean
'prüft, ob es eine Datei überhaupt gibt
Dim wkb As Object
On Error Resume Next
Set wkb = Workbooks(sFile)
If Not wkb Is Nothing Then
WkbExists = True
End If
On Error GoTo 0
End Function
Function WksSheetExists(sSheet As String) As Boolean
'prüft, ob es ein Blatt überhaupt gibt
Dim wks As Object
On Error Resume Next
Set wks = Sheets(sSheet)
If Not wks Is Nothing Then
WksSheetExists = True
End If
On Error GoTo 0
End Function
Grüße,
Klaus M.vdT.