automatische Archivierung

Forumthread: automatische Archivierung

23.02.2009 16:50:47

Rüdiger

Hallo
ich schreibe mit Excel Rechnungen, die müssen archiviert werden, allerdings nicht die gesamte Tabelle sondern nur der Druckbereich des einzelnen Blattes:
Ich habe es vor Jahren mit dem Makro-Recorder hingekriegt, blicke aber durch den Code nicht mehr durch.
Heute hab ich es vesucht neu aufzuzeichnen:
ich kopiere den Druckbereich in die Zwischenablage,
öffne eine Tabelle, die nur ein leeres Blatt enthält,
Zwischenablage einfügen (jetzt sind alle Formatierungen weg....doof),
diese Datei speichern unter der Rechnungsnummer die in einer bestimmten Zelle steht,
die Hilfstabelle schließen.
Im Augenblick stoße ich mich daran, dass die Spaltenbreiten in der archivierten Datei nicht mehr so wie im Original sind.
Hilfe !
viele Grüsse
Rüdiger

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: automatische Archivierung

23.02.2009 16:55:30

Heinz
AW: automatische Archivierung

23.02.2009 18:05:54

Josef

AW: automatische Archivierung

23.02.2009 16:55:30

Heinz

Hi,
Spaltenbreiten/Zeilenhöhen werden nur kopiert, wenn ganze Spalten/Zeilen referenziert werden,
wenn das nicht geht, Maße gesondert übertragen.
mfg Heinz

AW: automatische Archivierung

23.02.2009 18:05:54

Josef

Hallo Rüdiger,
pass den Code an und probier mal.

' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub exportPrintarea()
  Dim rng As Range
  Dim objWB As Workbook
  Dim strName As String, strPath As String


  On Error GoTo ErrExit
  GMS

  strPath = "E:\Office\Excel\Forum" 'Speicherpfad - Anpassen!

  If Right(strPath, 1) <> "\" Then strPath = strPath & "\"

  With Sheets("Tabelle1") 'zu exportierende Tabelle - Anpassen!
    Set rng = .Range("Print_Area")
    strName = .Range("A1").Text & ".xls" 'Zelle mit dem zu vergebenden Namen - Anpassen!
  End With


  Set objWB = Workbooks.Add(xlWBATWorksheet)

  rng.Copy
  With objWB.Sheets(1).Range("A1")
    .PasteSpecial -4163
    .PasteSpecial -4122
    .PasteSpecial 8
  End With
  Application.CutCopyMode = False

  objWB.SaveAs strPath & strName
  objWB.Close

  ErrExit:
  If Err.Number <> 0 Then MsgBox Err.Number & vbLf & Err.Description, vbExclamation, "Fehler"
  GMS True
  Set rng = Nothing
  Set objWB = Nothing
End Sub

Public Sub GMS(Optional ByVal Modus As Boolean = False)
  Static lngCalc As Long

  With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Not Modus Then lngCalc = .Calculation
    If Modus And lngCalc = 0 Then lngCalc = -4105
    .Calculation = IIf(Modus, lngCalc, -4135)
    .Cursor = IIf(Modus, -4143, 2)
  End With

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Forumthread: automatische Archivierung

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread