problem mit Speichern in neue Mappe

Sub Druckbereichspeichern() Dim wb As Workbook, ws As Worksheet, NewName as String, rBereich As String Set wb = ActiveWorkbook Set ws = ActiveSheet If ActiveSheet.PageSetup.PrintArea = "" Then MsgBox "Kein Druckbereich festgelegt!" & Chr (10) & _ "Vorgang abgebrochen.": Exit Sub rBereich = ActiveSheet.PageSetup.PrintArea NewName = Range ("A13") .Value Application.ScreenUpdating = False Application.Workbooks.Add wb.Worksheets (ws.Index) .Range (rBereich) .Copy Range ("A1") .PasteSpecial Application.CutCopyMode = False Range ("A1") .Select With Workbook .SaveAS wb.Path & "\" & NewName, wb.FileFormat .Close End With wb.Activate Application.ScreenUpdating = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Micha,
versuche es so.

Sub Druckbereichspeichern()
  Dim objSh As Worksheet, objNewSh As Worksheet
  Dim rng As Range
  Dim strFileName As String, strPath As String
  
  On Error GoTo ErrExit
  
  Application.ScreenUpdating = False
  
  strPath = "D:\Excel\gespeicherte Mappen"
  
  If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
  
  
  Set objSh = ActiveSheet
  
  With objSh
    If .PageSetup.PrintArea = "" Then
      MsgBox "Kein Druckbereich festgelegt!" & Chr(10) & "Vorgang abgebrochen."
    Else
      Set rng = .Range(objSh.PageSetup.PrintArea)
      strFileName = .Range("A13").Text
      objSh.Copy
      
      Set objNewSh = ActiveSheet
      
      If rng.Rows(1).Row > 1 Then
        objNewSh.Range(objNewSh.Cells(1, 1), objNewSh.Cells(rng.Rows(1).Row - 1, 1)).EntireRow.Delete
      End If
      If rng.Rows(rng.Rows.Count + rng.Rows(1).Row).Row < .Rows.Count Then
        objNewSh.Range(objNewSh.Cells(rng.Rows.Count + 1, 1), objNewSh.Cells(.Rows.Count, _
          1)).EntireRow.Delete
      End If
      If rng.Columns(1).Column > 1 Then
        objNewSh.Range(objNewSh.Cells(1, 1), objNewSh.Cells(1, rng.Columns(1).Column - _
          1)).EntireColumn.Delete
      End If
      If rng.Columns(rng.Columns.Count + rng.Columns(1).Column).Column < .Columns.Count Then
        objNewSh.Range(objNewSh.Cells(1, rng.Columns.Count + 1), objNewSh.Cells(1, _
          .Columns.Count)).EntireColumn.Delete
      End If
    End If
  End With
  
  If Not objNewSh Is Nothing Then
    objNewSh.Parent.SaveAs strPath & strFileName, objSh.Parent.FileFormat
    objNewSh.Parent.Close
  End If
  
  objSh.Activate
  
  ErrExit:
  
  Application.ScreenUpdating = True
  
  Set rng = Nothing
  Set objSh = Nothing
  Set objNewSh = Nothing
End Sub

« Gruß Sepp »

Beliebteste Forumthreads (12 Monate)

problem mit Speichern in neue Mappe

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread