Blatt mit Bild mittels Makro kopieren
22.12.2014 13:50:42
Debian
Ich habe in Excel ein bescheidenes Rechnungsprogramm gebastelt. Es besteht aus den Blättern "Kundenstammdaten" mit den Adressen, Rechnungsnummern etc., dem Blatt "Verkauf fortlaufend" in dem die einzelnen Rechnungspositionen für jeden Kunde eines Monats eingegeben werden, sowie dem Blatt "Rechnungsformular", welches eine leere Vorlage für alle zu erstellenden Rechnungen ist. In diesem Blatt hat es eine Dropdownliste, mittels derer der gewünschte Kunde ausgewählt wird, anschliessend klickt man den Button "Rechnung erstellen" an und alle erforderlichen Daten werden aus den ersten beiden Blättern in das Rechnungsformular übertragen. Die so erstellte Rechnung wird in der selben Mappe als Kopie (Werte ohne Formeln) gespeichert (ich benutze diese Mappe rechnerübergreifend auf Windows und Mac, da passen die Seitenumbrüche nicht genau, so das ich da nachjustieren muss bevor ich drucken kann).
Meine Frage ist nun diese:
Die zu druckende Rechnungskopie wird via dieses Makro erstellt:
Sub Kopie()
Application.Goto Reference:="Print_Area"
Selection.Copy
Sheets.Add after:=Sheets(ActiveWorkbook.Sheets.Count)
Selection.PasteSpecial (xlPasteColumnWidths)
Selection.PasteSpecial (xlPasteAll)
Selection.PasteSpecial (xlPasteValues)
'ActiveSheet.Paste 'Daten einfuegen
Application.CutCopyMode = False
ActiveWindow.DisplayZeros = False
ActiveSheet.Name = Left([A15], 10) & " - " & [D29]
'Seite einrichten
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.708661417322835)
.RightMargin = Application.InchesToPoints(0.511811023622047)
.TopMargin = Application.InchesToPoints(0.393700787401575)
.BottomMargin = Application.InchesToPoints(0.393700787401575)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0.393700787401575)
'Zeilenhoehe
Rows("39:39").RowHeight = 28.5
End With
End Sub
Sub Kopie_aktuelles_Blatt_ohne_Formeln()
Call SchutzAus
Dim WB As Workbook
Dim b As Range
Dim Anwort
Anwort = MsgBox("Aktuelles Tabellenblatt ohne Formeln in eine neue Mappe kopieren?", _
vbInformation + vbYesNo, "Tabellenblatt Kopieren Ja oder Nein.")
If Anwort = vbNo Then Exit Sub
Application.ScreenUpdating = False
'Aktuelles Tabellenblatt Kopieren
ActiveSheet.Copy
Set WB = ActiveWorkbook
' Formeln durch Zelleninhalt ersetzten
For Each b In WB.ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas)
b = b.Value2
Next b
Application.ScreenUpdating = True
Call SchutzEin
End Sub
Sub Druck()
Application.Goto Reference:="Print_Area"
Selection.PrintOut Copies:=2, Collate:=True
End Sub
Mein Problem ist nun, dass das Logo, welches ich in den Briefkopf des Rechnungsformulars einfüge, nicht in die Rechnungskopie übernommen wird. Auch nicht, wenn ich es in die Kopfzeile einfüge!) Wie muss der Code angepasst werden, damit das Logo mitgenommen wird?
Und das zweite: Weiss jemand einen Weg, wie ich die Seitenumbrüche so einrichten kann, das die Seitenränder und die Umbrüche zwischen Excel für Windows und Excel für Mac gleich bleiben? Das ist ein grosses Ärgernis.
Anbei die Musterdatei, damit ihr sehr, von was ich geschrieben habe.
Hier der Link dazu:
Die Datei https://www.herber.de/bbs/user/94544.xlsm wurde aus Datenschutzgründen gelöscht
Grüsse aus Zürich.
Debian