Bereich aus Tabellenblatt speichern in neue Datei
30.04.2020 11:26:31
fcs
Hallo olli,
nachfolgend 2 Varianten, um den Zellbereich eines Tabellenblatts in eine neue Arbeitsmappe zu kopieren.
Variante 1 kopiert das komplette Tabellenblatt und löscht nach dem Ersetzen der Formeln durch Werte die nicht gewünschten Zeilen und Spalten.
Diese Variante kann verwendet werden, wenn im Code-Modul des Tabellenblatts kein Code enthalten ist.
Variante 2 erstellt zunächst eine neue Arbeitsmappe mit einem Tabellenblatt.
Dann wird der gewünschten Zellbereich kopiert, wobei erst Spaltenbreiten, dann Formate und zum Schluss die Werte eingefügt werden.
Zusätzlich werden wesentliche Einstellungen für das Einrichten der Seite übertragen.
LG
Franz
Sub Auswertung_ohne_Formeln_Variante1()
' Auswertung_ohne_Formeln Makro
' Zellbereich in einer neuen Datei ohne Formel speichern
Dim wkbQuelle As Workbook
Dim wksQuelle As Worksheet
Dim wkbAuswertung As Workbook
Dim wksAuswertung As Worksheet
Dim spaAW_1 As Long, zeiAW_1 As Long, spaAW_L As Long, zeiAW_L As Long
Dim zeiL As Long, spaL As Long
Dim sPfad As String, sDateiname As String
Set wkbQuelle = ActiveWorkbook
Set wksQuelle = wkbQuelle.Worksheets("Tabelle1") 'Tabellenblatt mit zu speicernden Daten
With wksQuelle
spaAW_1 = 1 'Spalte A - 1. Spalte in Auswertung
zeiAW_1 = 1 '1. Zeile in Auswertung
spaAW_L = 9 'Spalte I - Letzte Spalte in Auswertung
zeiAW_L = 35 'Letzte Zeile in Auswertung
'Pfad in Variable einlesen
sPfad = .Range("A39").Text
'falls nicht vorhanden dann "\" am Pfad anfügen
If Right(sPfad, 1) "\" Then sPfad = sPfad & "\"
'Dateiname einlesen
sDateiname = .Range("A1").Text & "_" & .Range("G1").Text & ".xls"
If Dir(sPfad & sDateiname) "" Then
If MsgBox("Datei """ & sDateiname & """ existiert schon!" & vbLf _
& "Datei überschreiben?", vbQuestion + vbOKCancel, _
"Auswertung in neue Arbeitsmappe") = vbCancel Then
Exit Sub
End If
End If
sDateiname = sPfad & sDateiname
With .UsedRange
'letzte benutzte Zeile
zeiL = .Row + .Rows.Count - 1
'letzte benutzte Spalte
spaL = .Column + .Columns.Count - 1
End With
End With
'Tabelelnblatt in neue Arbeitsmappe kopieren
wksQuelle.Copy
Set wkbAuswertung = ActiveWorkbook
Set wksAuswertung = wkbAuswertung.Worksheets(1)
With wksAuswertung
.Name = wksQuelle.Name
'Formeln durch Werte ersetzen
.UsedRange.Copy
.UsedRange.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Überzählige Spalten löschen
If spaL > spaAW_L Then
.Range(.Columns(spaAW_L + 1), .Columns(spaL)).Delete
End If
'Überzählige Zeilen löschen
If zeiL > zeiAW_L Then
.Range(.Rows(zeiAW_L + 1), .Rows(zeiL)).Delete
End If
'Unterzählige Spalten löschen
If spaAW_1 > 1 Then
.Range(.Columns(1), .Columns(spaAW_L - 1)).Delete
End If
'Unterzählige Zeilen löschen
If zeiAW_1 > 1 Then
.Range(.Rows(1), .Rows(zeiAW_L - 1)).Delete
End If
End With
Range("A1").Select
'Auswertung speichern
Application.DisplayAlerts = False
wkbAuswertung.SaveAs Filename:=sDateiname, FileFormat:=xlExcel8, _
addtomru:=True
Application.DisplayAlerts = True
'Auswertung schliessen
wkbAuswertung.Close savechanges:=False
'Quellmappe aktivieren
wkbQuelle.Activate
End Sub
Sub Auswertung_ohne_Formeln_Variante2()
' Auswertung_ohne_Formeln Makro
' Zellbereich in einer neuen Datei ohne Formel speichern
Dim wkbQuelle As Workbook
Dim wksQuelle As Worksheet
Dim wkbAuswertung As Workbook
Dim wksAuswertung As Worksheet
Dim spaAW_1 As Long, zeiAW_1 As Long, spaAW_L As Long, zeiAW_L As Long
Dim rngAuswertung As Range
Dim sPfad As String, sDateiname As String
Set wkbQuelle = ActiveWorkbook
Set wksQuelle = wkbQuelle.Worksheets("Tabelle1") 'Tabellenblatt mit zu speichernden Daten
With wksQuelle
spaAW_1 = 1 'Spalte A - 1. Spalte in Auswertung
zeiAW_1 = 1 '1. Zeile in Auswertung
spaAW_L = 9 'Spalte I - Letzte Spalte in Auswertung
zeiAW_L = 35 'Letzte Zeile in Auswertung
'Pfad in Variable einlesen
sPfad = .Range("A39").Text
'falls nicht vorhanden dann "\" am Pfad anfügen
If Right(sPfad, 1) "\" Then sPfad = sPfad & "\"
'Dateiname einlesen
sDateiname = .Range("A1").Text & "_" & .Range("G1").Text & ".xls"
If Dir(sPfad & sDateiname) "" Then
If MsgBox("Datei """ & sDateiname & """ existiert schon!" & vbLf _
& "Datei überschreiben?", vbQuestion + vbOKCancel, _
"Auswertung in neue Arbeitsmappe") = vbCancel Then
Exit Sub
End If
End If
sDateiname = sPfad & sDateiname
Set rngAuswertung = .Range(.Cells(zeiAW_1, spaAW_1), .Cells(zeiAW_L, spaAW_L))
End With
'Neue Arbeitsmappe anlegen
Set wkbAuswertung = Application.Workbooks.Add(Template:=xlWBATWorksheet)
Set wksAuswertung = wkbAuswertung.Worksheets(1)
With wksAuswertung
rngAuswertung.Copy
With .Range("A1")
.PasteSpecial Paste:=xlPasteColumnWidths
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValues
End With
With .PageSetup
.Orientation = wksQuelle.PageSetup.Orientation
.TopMargin = wksQuelle.PageSetup.TopMargin
.BottomMargin = wksQuelle.PageSetup.BottomMargin
.LeftMargin = wksQuelle.PageSetup.LeftMargin
.RightMargin = wksQuelle.PageSetup.RightMargin
.HeaderMargin = wksQuelle.PageSetup.HeaderMargin
.FooterMargin = wksQuelle.PageSetup.FooterMargin
.LeftHeader = wksQuelle.PageSetup.LeftHeader
.CenterHeader = wksQuelle.PageSetup.CenterHeader
.RightHeader = wksQuelle.PageSetup.RightHeader
.LeftFooter = wksQuelle.PageSetup.LeftFooter
.CenterFooter = wksQuelle.PageSetup.CenterFooter
.RightFooter = wksQuelle.PageSetup.RightFooter
End With
Application.CutCopyMode = False
End With
Range("A1").Select
'Auswertung speichern
Application.DisplayAlerts = False
wkbAuswertung.SaveAs Filename:=sDateiname, FileFormat:=xlExcel8, _
addtomru:=True
Application.DisplayAlerts = True
'Auswertung schliessen
wkbAuswertung.Close savechanges:=False
'Quellmappe aktivieren
wkbQuelle.Activate
End Sub