VBA Registerblatt auslagern in neuer Datei

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Uwe!
Das geht z.B. so!

' **********************************************************************
' Modul: Modul4 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub SheetToMapp()
Dim objNew As Workbook
Dim objSh As Worksheet
Dim objShp As Object
Dim rngCopy As Range
Dim strName As String

On Error GoTo ErrExit

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .DisplayAlerts = False
  .Calculation = xlCalculationManual
End With

strName = Application.GetSaveAsFilename(InitialFilename:="Neu", _
  FileFilter:="Excel Files (*.xls), *.xls")

If strName = "Falsch" Then GoTo ErrExit

Set objSh = Sheets("Tabelle3") 'Quelltabelle - anpassen

Set rngCopy = objSh.Range("A1:C25") ' Bereich der kopiert werden soll! - anpassen

Set objNew = Workbooks.Add(xlWBATWorksheet)

rngCopy.Copy objNew.Sheets(1).Range("A1")

For Each objShp In objNew.Sheets(1).Shapes
  objShp.Delete
Next

objNew.SaveAs strName

objNew.Close

ErrExit:

If Err.Number > 0 Then
  MsgBox Err.Number & vbLf & Err.Description, , "Fehler"
  Err.Clear
End If

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .DisplayAlerts = True
  .Calculation = xlCalculationAutomatic
End With

Set objNew = Nothing
Set objSh = Nothing

End Sub

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Hallo Uwe!
Kein Problem!

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub SheetToMapp()
Dim objNew As Workbook
Dim objSh As Worksheet
Dim objShp As Object
Dim rngCopy As Range, rngCol As Range
Dim strName As String

On Error GoTo ErrExit

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .DisplayAlerts = False
  .Calculation = xlCalculationManual
End With

strName = Application.GetSaveAsFilename(InitialFilename:="Neu", _
  FileFilter:="Excel Files (*.xls), *.xls")

If strName = "Falsch" Then GoTo ErrExit

Set objSh = Sheets("Tabelle1") 'Quelltabelle - anpassen

Set rngCopy = objSh.Range("A1:C25") ' Bereich der kopiert werden soll! - anpassen

Set objNew = Workbooks.Add(xlWBATWorksheet)

rngCopy.Copy objNew.Sheets(1).Range("A1")

For Each objShp In objNew.Sheets(1).Shapes
  objShp.Delete
Next

For Each rngCol In rngCopy.Columns
  objNew.Sheets(1).Columns(rngCol.Column).Hidden = rngCol.Hidden
Next

objNew.SaveAs strName

objNew.Close

ErrExit:

If Err.Number > 0 Then
  MsgBox Err.Number & vbLf & Err.Description, , "Fehler"
  Err.Clear
End If

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .DisplayAlerts = True
  .Calculation = xlCalculationAutomatic
End With

Set objNew = Nothing
Set objSh = Nothing

End Sub

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Beliebteste Forumthreads (12 Monate)

VBA Registerblatt auslagern in neuer Datei

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

311 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA Registerblatt auslagern in neuer Datei

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

311 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread