HERBERS Excel-Forum - das Archiv
Thema: Formatierung f. Druckbereich als neue Arbeitsmappe | Herbers Excel-Forum
Formatierung f. Druckbereich als neue Arbeitsmappe
Rainer
Hallo,
möchte aus einer Tabelle ein Arbeitsblatt kopieren und in einem Verzeichnis zum versenden speichern.
Dabei habe ich zwei weselntliche Punkte zu beachten:
Als idealste Lösung habe ich derzeit einen Code, welcher mir den Druckbereich kopiert und in einem neuen Arbeitsblatt speichert.
Das Problem hier: Der Inhalt wird völlig ohne Formatierung in das neue Blatt übergeben.
Sprich: keine Rahmen, keine Farben, falsche Spaltenbreite etc.
Hat mir jemand einen Rat?
Gruß Rainer
AW: Formatierung f. Druckbereich als neue Arbeitsmappe
Josef
Hallo Rainer,
vom Prinzip her, geht das z.B. so.
Sub copyPrintArea()
Dim objWb As Workbook, rng As Range
With ThisWorkbook.Sheets("Tabelle3") 'Tabellenname anpassen!
Set rng = .Range(.PageSetup.PrintArea)
End With
Set objWb = Workbooks.Add(xlWBATWorksheet)
With objWb
With .Sheets(1).Range("A1")
rng.Copy
.PasteSpecial -4104
.PasteSpecial -4163
.PasteSpecial -4122
.PasteSpecial 8
End With
Application.CutCopyMode = False
.SaveAs "E:\Temp\druckbereich.xls" 'Speicherpfad/Name - Anpassen!
.Close
End With
Set objWb = Nothing
Set rng = Nothing
End Sub
Dim objWb As Workbook, rng As Range
With ThisWorkbook.Sheets("Tabelle3") 'Tabellenname anpassen!
Set rng = .Range(.PageSetup.PrintArea)
End With
Set objWb = Workbooks.Add(xlWBATWorksheet)
With objWb
With .Sheets(1).Range("A1")
rng.Copy
.PasteSpecial -4104
.PasteSpecial -4163
.PasteSpecial -4122
.PasteSpecial 8
End With
Application.CutCopyMode = False
.SaveAs "E:\Temp\druckbereich.xls" 'Speicherpfad/Name - Anpassen!
.Close
End With
Set objWb = Nothing
Set rng = Nothing
End Sub
Gruß Sepp
AW: Formatierung f. Druckbereich als neue Arbeitsmappe
Rainer
Hallo Sepp,
danke für Deine Hilfe.
Habe nun eine Fehlermeldung (Für diese Aktion müssen alle verbundenen Zellen dieselbe Größe haben).
Programm hält bei .PasteSpecial -4163
Hoffe, dass es für alle Formatierungen ein ".PasteSpecial ####" gibt.
Wenn ich da richtig liege, kann ich die Ziffern wo nachlesen?
Gruß Rainer
mit verb. Zellen kannst du es vergessen!
Josef
Hallo Rainer,
{Boris} Statement über Verbundene Zellen: https://www.herber.de/forum/archiv/900to904/t902693.htm
Wozu verbundene Zellen, die bringen nur Probleme.
Alle xlPasteType-Werte kannst du in der Hilfe nachlesen. (Cursor auf .PasteSpecial setzen und F1 drücken)
Gruß Sepp
AW: Formatierung f. Druckbereich als neue Arbeitsmappe
Rainer
Hallo Sepp,
eine Idee habe ich noch.
Könnte man nicht vom ausgewählten Arbeitsblatt eine Kopie machen, die Inhalte dann leeren und dann in dieses neue Arbeitsblatt die Inhalte einfügen?
Beispiel:
Arbeitsblätter: [ Erfassung│Plan1│Plan2│Plan3│Plan4│PlanCopy ]
Wenn nun Plan2 versendet werden soll folglich
Plan2 kopieren und als PlanCopy wieder anlegen/überschreiben
PlanCopy Inhalte löschen
Plan2 kopieren und Inhalte in PlanCopy einfügen
PlanCopy "speichern unter ... C:\Temp\"
PlanCopy C:\Temp\ vesenden
Könnte das so funktionieren?
Gruß Rainer
AW: Formatierung f. Druckbereich als neue Arbeitsmappe
Josef
Hallo Rainer,
auch wenn du meinen Hinweis auf die verbundenen Zellen ignorierst, sie werden dich einholen;-))
Probier's so.
Sub copyPrintArea2()
Dim objWb As Workbook, rng As Range, rngC As Range, rngDel As Range
ActiveSheet.Copy
Set objWb = ActiveWorkbook
With objWb
With .Sheets(1)
.UsedRange = .UsedRange.Value
Set rng = .Range(.PageSetup.PrintArea)
For Each rngC In .UsedRange.Columns
If Intersect(rngC, rng) Is Nothing Then
If rngDel Is Nothing Then
Set rngDel = rngC.EntireColumn
Else
Set rngDel = Union(rngDel, rngC.EntireColumn)
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.Delete
Set rngDel = Nothing
For Each rngC In .UsedRange.Rows
If Intersect(rngC, rng) Is Nothing Then
If rngDel Is Nothing Then
Set rngDel = rngC.EntireRow
Else
Set rngDel = Union(rngDel, rngC.EntireRow)
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.Delete
Set rngDel = Nothing
End With
.SaveAs "E:\Temp\Druckbereich.xls"
.Close
End With
Set objWb = Nothing
Set rng = Nothing
Set rngDel = Nothing
Set rngC = Nothing
End Sub
Dim objWb As Workbook, rng As Range, rngC As Range, rngDel As Range
ActiveSheet.Copy
Set objWb = ActiveWorkbook
With objWb
With .Sheets(1)
.UsedRange = .UsedRange.Value
Set rng = .Range(.PageSetup.PrintArea)
For Each rngC In .UsedRange.Columns
If Intersect(rngC, rng) Is Nothing Then
If rngDel Is Nothing Then
Set rngDel = rngC.EntireColumn
Else
Set rngDel = Union(rngDel, rngC.EntireColumn)
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.Delete
Set rngDel = Nothing
For Each rngC In .UsedRange.Rows
If Intersect(rngC, rng) Is Nothing Then
If rngDel Is Nothing Then
Set rngDel = rngC.EntireRow
Else
Set rngDel = Union(rngDel, rngC.EntireRow)
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.Delete
Set rngDel = Nothing
End With
.SaveAs "E:\Temp\Druckbereich.xls"
.Close
End With
Set objWb = Nothing
Set rng = Nothing
Set rngDel = Nothing
Set rngC = Nothing
End Sub
Gruß Sepp
AW: Formatierung f. Druckbereich als neue Arbeitsmappe
Rainer
Hallo Sepp,
auch wenn du meinen Hinweis auf die verbundenen Zellen ignorierst, sie werden dich einholen;-))
Dennoch danke für den zweiten Code, werde ich gleich mal testen.
Ansonsten bleibt mir, den ausgewählten Bereich innerhalb der eMail unter zu bringen.
Habe jedoch meine UserForm so gut wie fertig.
Nun fehlt eben nur noch der Anhang des Arbeitsblattes.
Sollte alles scheitern muss ich mal schauen, dass ich den Druckbereich noch irgendwie (zusätzlich zum Inhalt des Textfeldes) in die eMail dazu bekomme.
Gruß Rainer
AW: Formatierung f. Druckbereich als neue Arbeitsmappe
Rainer
Hallo Sepp,
nach der Mitteilung von vorher nenn ich aber das mal eine Glanzleistung.
Formatierung der Zellen ist einwandfrei.
Ne Kleinigkeit ist noch zu korrigieren (Ausblenden oder löschen der CommandButton's im neuen Sheet)
Bekomme ich aber vermutlich hin.
Für heute mache ich allerdings Schluß.
Vielen Dank für Deine Hilfe und noch schönen Abend.
Gruß Rainer
Dialog-Beispiele
Excel-Beispiele