paste Methode über versch. Workbooks
12.12.2020 13:27:13
Jochen
Hab wie immer schon viel probiert und gesucht, komme aber nicht weiter der PASTE Befehl will nicht funktionieren. (Fehler 1004)
Habe einige verbundene Zellen, die löse ich auf. Geht aber trotzdem nicht.
Hier der Code:
Sub DMSundExcelÜbergabe()
Dim sDruckerAktuell, sDruckerNeu, DateinameCompStr, BlattNamStr, PasswortStr As String
Dim QWB, ZWB As Workbook
Dim QWS1, ZWS1 As Worksheet
Set QWB = ActiveWorkbook
Set QWS1 = QWB.Sheets(1)
PasswortStr = "XXX"
DateinameCompStr = ActiveWorkbook.Path & "\12-2020.xlsm"
BlattNamStr = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5)
QWS1.Range("E5:AE40").UnMerge 'verbundene Zellen müssen aufgelöst werden für kopieren
QWS1.Range("E5:AE40").Select ' Daten werden markiert
QWS1.Selection.Copy ' Daten werden kopiert
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Workbooks.Open Filename:=DateinameCompStr, Password:=PasswortStr 'Vorlage bzw. Master ö _
ffnen
Set ZWB = Workbooks("12-2020.xlsm")
Set ZWS1 = ZWB.Sheets(BlattNamStr)
ZWS1.Select
With Selection
.Range("E5:AE40").UnMerge 'verbundene Zellen müssen aufgelöst werden für kopieren
.Range("E5").Select
.Paste
.Range("E5:G5").Merge 'Zellenverbunde wieder herstellen
.Range("E6:G6").Merge 'Zellenverbunde wieder herstellen
.Range("I5:J5").Merge 'Zellenverbunde wieder herstellen
End With
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
ZWB.Close SaveChanges:=True ' Datei speichern
QWS1.Range("E5:G5").Merge 'Zellenverbunde wieder herstellen
QWS1.Range("E6:G6").Merge 'Zellenverbunde wieder herstellen
QWS1.Range("I5:J5").Merge 'Zellenverbunde wieder herstellen
QWB.Save ' Datei speichern
'Aktuellen Drucker merken und mit DMS-Drucker drucken
sDruckerAktuell = Application.ActivePrinter
sDruckerNeu = "\\dms\Archivdrucker"
QWS1.PrintOut ActivePrinter:=sDruckerNeu
Application.ActivePrinter = sDruckerAktuell
QWB.Close SaveChanges:=False
End Sub