Sub NachDruckversion()
d.h. den Code in die Auffang.xlsm und nach Vorbemerkung ggf. anpassen
Gruß
Option Explicit
'***********************************************************************************
'Zieldateiname und Typ und die Tabellennamen sind ggf. direkt im Code zu ändern
'***********************************************************************************
Sub NachDruckversion()
'aktive Mappe = Auffang.xlsm
Dim arrCH() As Variant 'Datenfeld1
Dim arrRT() As Variant 'Datenfeld2
Dim rngZiel As Range 'Zielzelle
Dim rngQuelle As Range 'zu verschiebende Daten
Dim lngLast As Long 'jew. letzte Zeile
'nur aktive Mappe = Auffang.xlsm
If Workbooks.Count > 1 Then Exit Sub
'Seiten gefüllt, sonst Abbruch
With Sheets("Zweiteseite")
If Application.WorksheetFunction.CountA(.Cells) = 0 Then Exit Sub
End With
With Sheets("Dritteseite")
If Application.WorksheetFunction.CountA(.Cells) = 0 Then Exit Sub
End With
On Error GoTo eHandler
Application.ScreenUpdating = False
Workbooks.Open Filename:=ThisWorkbook.Path & "\Druckversion.xlsm"
'Mappe = Druckversion.xlsm - leeren
With Workbooks(2)
With .Sheets("Zweite")
.Cells.Clear
End With
With .Sheets("Dritte")
.Cells.Clear
End With
End With
'Daten aufnehmen
With Workbooks(1)
'je Tabelle
With .Sheets("Zweiteseite")
'benutzer Bereich
lngLast = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
With .Columns("C:H")
Set rngQuelle = Range(.Rows(1), .Rows(lngLast))
'in Datenfeld
arrCH = rngQuelle.Value
End With
'ditto
With .Columns("R:T")
Set rngQuelle = Range(.Rows(1), .Rows(lngLast))
arrRT = rngQuelle.Value
End With
End With
'ins Ziel schreiben
Set rngZiel = Workbooks(2).Sheets("Zweite").Range("A1")
rngZiel.Resize(UBound(arrCH, 1), UBound(arrCH, 2)).Value = arrCH
'ditto
Set rngZiel = Workbooks(2).Sheets("Zweite").Range("G1")
rngZiel.Resize(UBound(arrRT, 1), UBound(arrRT, 2)).Value = arrRT
'wie vor, andere Tabelle
With .Sheets("Dritteseite")
lngLast = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
With .Columns("C:H")
Set rngQuelle = Range(.Rows(1), .Rows(lngLast))
arrCH = rngQuelle.Value
End With
With .Columns("R:T")
Set rngQuelle = Range(.Rows(1), .Rows(lngLast))
arrRT = rngQuelle.Value
End With
End With
Set rngZiel = Workbooks(2).Sheets("Dritte").Range("A1")
rngZiel.Resize(UBound(arrCH, 1), UBound(arrCH, 2)).Value = arrCH
Set rngZiel = Workbooks(2).Sheets("Dritte").Range("G1")
rngZiel.Resize(UBound(arrRT, 1), UBound(arrRT, 2)).Value = arrRT
End With
'speichern, schließen
Workbooks(2).Close True
eHandler:
Select Case Err.Number
Case 0 'erfolgreich
Case Else
MsgBox "Fehler bei der Ausführung"
End Select
Application.ScreenUpdating = True
End Sub
|