Excel - VBA Script _ Speichern eines bestimmten Bereiches

[ds_cheater]

Hallo Leute,
ich habe mir im Internet ein VBA Script ergooglet, welches mein aktuelles Tabellenblatt in einer neuen Arbeitsmappe speichert.

Sub Speichern_unter_neuem_Namen_Typ01()
Dim Neuer_Dateiname As String

Rem Aktive Tabelle kopieren
ActiveSheet.Copy

Rem Speicherpfad und Dateiname anfordern
Neuer_Dateiname = Application.GetSaveAsFilename(InitialFileName:="", fileFilter:="Excel-Arbeitsmappe (*.xlsx), *.xlsx")

Rem Abbruch wenn Dateiname leer
If Neuer_Dateiname = "Falsch" Then Exit Sub

Rem Aktive Arbeitsmappe speichern
ActiveWorkbook.SaveAs Filename:=Neuer_Dateiname, FileFormat:=xlOpenXMLWorkbook
End Sub

Dies klappt auch wunderbar. Ich hätte aber den Wunsch, dass beim Speichern ab einer bestimmen Zeile bis zur letzten nicht leeren Zeile gespeichert wird, da der Rest drum herum nicht benötigt wird.

Könnte mir bitte jemand kurz helfen? Danke!

Grüße, cheater

 

[Pennerschwert]

Einfach Googlen:

http://www.excel-inside.de/vba-loes...zte-spalte-und-letzte-zelle-per-vba-ermitteln

Und dann anstatt "ActiveSheet.Copy" den gewünschten Bereich mittels "Range" definieren.

 

[ds_cheater]

Hi,
ich weiß für die Nicht-Fragesteller schaut es immer so aus, als ob man zu bequem zum Googlen ist (geht mir oft auch so). Aber tatsächlich habe ich schon Stunden Videos geschaut und gegoogelt, da ich ja durchaus etwas lernen möchte.

Fakt ist aber auch, dass ich viel zu wenig Ahnung von VBA habe (leider).
Aus meinen aktuellen Bemühungen ist nun folgendes herausgekommen:

Sub Speichern_unter_neuem_Namen_Typ01()
Dim Neuer_Dateiname As String

Rem Aktive Tabelle kopieren
ActiveSheet.Range("A4:HS62").Copy

Rem Speicherpfad und Dateiname anfordern
Neuer_Dateiname = Application.GetSaveAsFilename(InitialFileName:="", fileFilter:="Excel-Arbeitsmappe (*.xlsx), *.xlsx")

Rem Abbruch wenn Dateiname leer
If Neuer_Dateiname = "Falsch" Then Exit Sub

Rem Aktive Arbeitsmappe speichern
ActiveWorkbook.SaveAs Filename:=Neuer_Dateiname, FileFormat:=xlOpenXMLWorkbook
End Sub

Was aber leider übehaupt nicht das gewünschte Ergebnis liefert.

Grüße, Dominic

 

[Pennerschwert]

Versuch doch mal:

'Deklaration'
Dim letzte_Zeile As Long

'Ermittelt letzte belegte Zeile in Spalte A'
letzte_Zeile = ActiveSheet.Range("A65536").End(xlUp).Row

Und dann:

'Kopiert von Spalte A, Zeile 4 bis Spalte H, letzteZeile'
ActiveSheet.Range(Cells(4, 1), Cells(letzteZeile, 8)).Copy

Sicher nicht die eleganteste Lösung. Sollte aber eigentlich funktionieren.

 

[ds_cheater]

Habe es jetzt etwas (für meine Bedürfnisse) angepasst, bei deinem Code kam ein Fehler, wahrscheinlich weil ich zu doof zum zusammenkopieren war .

Sub Speichern_unter_neuem_Namen_Typ01()
'Deklaration'
Dim letzte_Zeile As Long

'Ermittelt letzte belegte Zeile in Spalte A'
letzte_Zeile = ActiveSheet.Range("A65536").End(xlUp).Row

Dim Neuer_Dateiname As String

'Kopiert von Spalte A, Zeile 4 bis Spalte H, letzteZeile'
ActiveSheet.Range("A4:I" & letzte_Zeile).Copy

Rem Speicherpfad und Dateiname anfordern
Neuer_Dateiname = Application.GetSaveAsFilename(InitialFileName:="", fileFilter:="Excel-Arbeitsmappe (*.xlsx), *.xlsx")

Rem Abbruch wenn Dateiname leer
If Neuer_Dateiname = "Falsch" Then Exit Sub

Rem Aktive Arbeitsmappe speichern
ActiveWorkbook.SaveAs Filename:=Neuer_Dateiname, FileFormat:=xlOpenXMLWorkbook
End Sub

Fakt ist, beim Speichern sehe ich nun, wie er den richtigen Bereich markiert, aber neu gepspeichert wird die komplette Arbeitsmappe.

Wenn du noch einmal dürber schauen würdest. Ich glaube dann haben wir es.

 

[cumulonimbus8]

Wäre gern gestern fertig geworden, aber…

Sub Beispiel()
Dim Neue_Datei_Name As String
Dim Diese_Datei_Name As String
Dim Dieses_Blatt As Integer
Dim Letzte_Zeile As Long
Dim Ziel_Range As Range
Dim Quell_Range As Range

 'Gleich aussteigen wenn hier schon etwas nicht stimmt
 Neue_Datei_Name = Application.GetSaveAsFilename(InitialFileName:="", fileFilter:="Excel-Arbeitsmappe (*.xlsx), *.xlsx")
 If Neue_Datei_Name_Suffix = "Falsch" Then Exit Sub

 'Diese beiden braucht man für die Range-Aktion weiter unten
 Diese_Datei_Name = ActiveWorkbook.Name
 Dieses_Blatt = ActiveSheet.Index
 'Letzte Zeile finden - unabhängig von möglicher maximaler Zeilenanzahl anhand Spalte A (= 1)
 Letzte_Zeile = Worksheets(Dieses_Blatt).Cells(Rows.Count, 1).End(xlUp).Row
 
 'Neue Arbeitsmappe (um einzufügen und so separiert zu speichern)
 Workbooks.Add
 ActiveWorkbook.SaveAs Neue_Datei_Name
 'Eine Zweitverwertung - Abtrennen der Pfadangabe
 Neue_Datei_Name = ActiveWorkbook.Name

 'Übernehmen der Daten ins erste jungfräuliche Blatt
 'Ohne Kopieren was die Zwischenablage zerstört, und das kann ich gar nicht leiden.
 ''Das nennt man "Volle Referenzierung" - immer eindeutige 'Hausnummern'
 Set Ziel_Range = Workbooks(Neue_Datei_Name).Worksheets(1).Range(Workbooks(Neue_Datei_Name).Worksheets(1).Cells(4, 1), Workbooks(Neue_Datei_Name).Worksheets(1).Cells(Letzte_Zeile, 9))
 Set Quell_Range = Workbooks(Diese_Datei_Name).Worksheets(Dieses_Blatt).Range(Workbooks(Diese_Datei_Name).Worksheets(Dieses_Blatt).Cells(4, 1), Workbooks(Diese_Datei_Name).Worksheets(1).Cells(Letzte_Zeile, 9))
 'Das .Value ist hier wichtig
 Ziel_Range = Quell_Range.Value
 'Änderungen speichern und neue Mappe schließen (denke mal, das ist sinnvoll)
 ActiveWorkbook.Close (True)
 
End Sub

Die Zeilen Set Ziel_Range, Set Quell_Range in voller Länge wirken erschreckend, und man könnte auch direkt zuweisen

 Workbooks(Neue_Datei_Name).Worksheets(1).Range(Workbooks(Neue_Datei_Name).Worksheets(1).Cells(4, 1), Workbooks(Neue_Datei_Name).Worksheets(1).Cells(Letzte_Zeile, 9)) = Workbooks(Diese_Datei_Name).Worksheets(Dieses_Blatt).Range(Workbooks(Diese_Datei_Name).Worksheets(Dieses_Blatt).Cells(4, 1), Workbooks(Diese_Datei_Name).Worksheets(1).Cells(Letzte_Zeile, 9))

sogar ohne das Value. Dabei ist das Rezept stur stupide einfach: Mappe.Blatt.Bereich(Zelle, Zelle) [oder bei nur einer Zelle Mappe.Blatt.Zelle], immer unter voller Angebe von vorne für jedes Element - Mappe, Mappe.Blatt, Mappe.Blatt.Zelle. Innerhalb der selben Mappe kann man die natürlich weglassen.

Wenn noch Fragen sind…

CN8

 

[Pennerschwert]

Das sieht doch schon besser aus, als meine eher primitive Antwort

@TE Lass dich nicht von den grünen Textpassagen irritieren, die Code Anzeige des Forums kommt wohl nicht mit den nicht abgeschlossenen Kommentaren zurecht. Kommentare stehen in VBA immer zwischen zwei Hochkommas:

'Ich bin ein Kommentar'

. Ansonsten sieht die Antwort aber vernünftig aus.

@cumulonimbus8

Danke für die schöne Möglichkeit die letzte Zeile zu ermitteln, das werde ich das nächste Mal auch in dieser Form verwenden

 

[Janush]

@CN8

Ich hätte da mal eine Fragen zu Deinem Code. Ist das "_SUFFIX" an "Neuer_Datei_Name" eine Funktion von VBA? Ich seh das nirgends als Variable deklariert.

Ansonsten sehr schicker Code, vor allem der Part mit der nicht veränderten Zwischenablage. Ist mir so noch nie in den Sinn gekommen, dass das einen Einfluss haben könnte.

 

[ds_cheater]

Hi,

@TE Lass dich nicht von den grünen Textpassagen irritieren, die Code Anzeige des Forums kommt wohl nicht mit den nicht abgeschlossenen Kommentaren zurecht. Kommentare stehen in VBA immer zwischen zwei Hochkommas:

Thx, das hatte ich bereits begriffen.

Ich hätte da mal eine Fragen zu Deinem Code. Ist das "_SUFFIX" an "Neuer_Datei_Name" eine Funktion von VBA? Ich seh das nirgends als Variable deklariert.

Glaube das kann ich auch beantworten. Das "_" erfüllt keine Funktion, es ist einfach Teil eines Namens.

Wenn noch Fragen sind…

Auch wenn es noch nicht funktionert, darf man dir ein Bier ausgeben? Oder vielleicht ne Flasche Wein, in Unterfranken gibt es beides.

Zur eigentlichen Frage: Ich habe den Code einfach mal in den VBA Editor kopiert. Klicke ich nun auf meinen Button, dann macht er mir eine neue Datei und meldet mir den Laufzeitfehler 1.004. Ich vermute mal ich habe meine Bereiche noch nicht korrekt definiert. Zwar habe ich mich nochmal dran versucht, aber bin kläglich gescheitert.

Hilft es dir, wenn ich dir die Datei kurz zusenden würde (ich möchte sie nicht unbedingt veröffentlichen).

Trotzdem schon einmal vielen Dank für deine Zeit .

Grüße, cheater

 

[Janush]

Glaube das kann ich auch beantworten. Das "_" erfüllt keine Funktion, es ist einfach Teil eines Namens.

Jetzt mal nicht gleich übermütig werden :-) was glaubst du denn macht der teil

If Neue_Datei_Name_Suffix = "Falsch" Then...

?

Kannst Du mir kurz erklären wo das_Suffix herkommt und wie/warum es funktioniert?

 

[ds_cheater]

Kurze Antwort. Ähm, ehrlich gesagt, ne . Sry!

 

[cumulonimbus8]

Das _Suffix ist ein Betriebsunfall von mir. Richtig muss ee natürlich so aussehen:

 Neue_Datei_Name = Application.GetSaveAsFilename(InitialFileName:="", fileFilter:="Excel-Arbeitsmappe (*.xlsx), *.xlsx")
 If Neue_Datei_Name = "Falsch" Then Exit Sub

Irgendwas hatte ich mit den Dateinamen versemmelt und das direkte Zuweisen der Ranges funktionierte nicht. Statt zu realisieren, dass mir der Code oben auch den Pfad mitliefert (gewusst zwar, aber nicht bedacht), war ich am reinen Mappennamen kleben geblieben und wollte den fürs Speichern mit Suffix (.xlsx → Neue_Datei_Name_Suffix) und für den Range ohne (Neue_Datei_Name) getrennt wissen. Leider habe ich oben das _Suffix zu löschen vergessen. Und schlimmer noch, im Range-Code brauche ich den Mappennamen mit seinem Suffix. Suffix weil mir ›Endung‹ oder gar ›Dateityp‹ beim Tippen zu lang war.
Mea Culpa.

Das mit dem beendeten Kommentar, das schließende Hochkomma, sollte ich mir mal merken.

Aus anderen Gründen reagiere ich immer stinkig wenn Code mir ohne meinen Willen in der Zwischenablage rumfummelt da ich die außerhalb brauche. Daher habe ich auch anderweitig Mühe investiert dieses .Copy zu umgehen wo es geht.

Was schließlich den 1004 verursacht - wo genau tut es das?

CN8

 

[Janush]

Ach verdammt, ich dachte es gibt ne einfache art die Dateiendung abzufragen. Also doch weiter Textbastelei, es sei denn ihr kennt eine Funktion

 

[Janush]

OK Freunde um das Ganze jetzt mal abzuschliessen, hier meine Gedanken zu dem Thema.

Wenn man den Code einfach von hier Kopiert und in den VBA Editor einfuegt, werden ein paar Zeilenumbrueche kopiert welche nicht sichtbar sind, aber vom Editor als Funktionen betrachtet werden und somit einen Fehler verursachen. Wenn man diese loescht, funktioniert das Script einwandfrei (bis auf die falsche Variable mit dem _Suffix).

Ich habe an CN8's code mal ein wenig rumgebastelt und eine Version geschrieben welche die aktuelle Auswahl im Sheet in ein neues Excelfile speichert. Wenn man die Datei oeffnet, wird direkt ein Speichern-Knopf angezeigt. Wenn man jetzt ein paar Zellen markiert und auf diesen Knopf drueckt, wird CN8's code ausgeloest.

Anbei mal der Coder

#1 ThisWorkbook

Option Explicit

'Event Trigger wenn Excelfile geoeffnet wird
Private Sub Workbook_Open()
'Hier wird nur das UserForm aufgerufen
SaveRange.Show
End Sub

#2 UserForm

Option Explicit

'Im UserForm selbst gibt es nur eine SubRoutine
'welche mit dem Button "ButtonSave" verbunden ist
'und bei Click ausgeloest wird.
Private Sub ButtonSave_Click()
'Wir definieren eine Variable r as Range
'und weisen dieser die aktuelle Auswahl im
'Excelfile zu.
Dim r As Range
Set r = Selection
  
'Hier rufen wir die Subroutine "SaveNewFile" auf
'und uebergeben ihr die aktuelle Auswahl r
'und die Auswahl r normalisiert auf die Zelle "A1"

'Hier in r.Offset - erste Zeile der Auswahl und - erste Spalte
'der Auswahl
SaveNewFile r, r.Offset((r.Row - 1) * -1, (r.Column - 1) * -1)

'Freigabe der Variable r
Set r = Nothing
End Sub

#3 Main Module

Option Explicit
'Main Module, haelt alle wichtigen Funktionen
'und SubRoutinen

'Hier SaveNewFile uebernommen aus CN8's code und leicht angepasst
'Die Routine nimmt zwei Range objects,
'Aktuelle Markierung und Zielmarkierung
Public Sub SaveNewFile(ByVal Quell_Range As Range, ByVal TargetRange As Range)
Dim Neue_Datei_Name  As String
Dim Ziel_Range       As Range

 'Gleich aussteigen wenn hier schon etwas nicht stimmt
 'GetSaveAsFilename oeffnet den Save File As Dioalog
 'und gibt den ausgewaehlten Dateinamen als string zurueck
 'bei nichtauswahl wird "Falsch" oder "False" zurueckgegeben
 'in diesem Fall beenden wir direkt die Routine
 Neue_Datei_Name = Application.GetSaveAsFilename(InitialFileName:="", fileFilter:="Excel-Arbeitsmappe (*.xlsx), *.xlsx")
 If Neue_Datei_Name = "False" Or Neue_Datei_Name = "Falsch" Then Exit Sub

 'Neue Arbeitsmappe hinzufuegen und unter dem ausgefaehlten Namen abspeichern
 Workbooks.Add
 ActiveWorkbook.SaveAs Neue_Datei_Name
 
 'Eine Zweitverwertung - Abtrennen der Pfadangabe
 Neue_Datei_Name = ActiveWorkbook.Name

 'Übernehmen der Daten ins erste jungfräuliche Blatt
 'Ohne Kopieren was die Zwischenablage zerstört, und das kann ich gar nicht leiden.
 'Das nennt man "Volle Referenzierung" - immer eindeutige 'Hausnummern'
 'Hier wird die uebergebene Zieladresse auf das neue Worksheet uebertragen
 'in .Range(TargetRange.Address)
 Set Ziel_Range = Workbooks(Neue_Datei_Name).Worksheets(1).Range(TargetRange.Address)
 
 'Das .Value ist hier wichtig
 Ziel_Range = Quell_Range.Value
 
 'Änderungen speichern und neue Mappe schließen (denke mal, das ist sinnvoll)
 ActiveWorkbook.Close (True)
End Sub

Und um das Ganze zu vereinfachen, hier noch die Datei als Anhang.

Anhang anzeigen SaveSelection.zip

Beste Gruesse
Martin

 

[ds_cheater]

Mahlzeit ,
tut mir leid, habe bisschen gebraucht mit dem Antworten.

@cumulonimbus8
Ich hab deinen Code noch um deine Korrektur ergänzt, sodass der Code nun so aussieht:

    Sub Beispiel()
    Dim Neue_Datei_Name As String
    Dim Diese_Datei_Name As String
    Dim Dieses_Blatt As Integer
    Dim Letzte_Zeile As Long
    Dim Ziel_Range As Range
    Dim Quell_Range As Range
     
     'Gleich aussteigen wenn hier schon etwas nicht stimmt
     Neue_Datei_Name = Application.GetSaveAsFilename(InitialFileName:="", fileFilter:="Excel-Arbeitsmappe (*.xlsx), *.xlsx")
     If Neue_Datei_Name = "Falsch" Then Exit Sub
     
     'Diese beiden braucht man für die Range-Aktion weiter unten
     Diese_Datei_Name = ActiveWorkbook.Name
     Dieses_Blatt = ActiveSheet.Index
     'Letzte Zeile finden - unabhängig von möglicher maximaler Zeilenanzahl anhand Spalte A (= 1)
     Letzte_Zeile = Worksheets(Dieses_Blatt).Cells(Rows.Count, 1).End(xlUp).Row
     
     'Neue Arbeitsmappe (um einzufügen und so separiert zu speichern)
     Workbooks.Add
     ActiveWorkbook.SaveAs Neue_Datei_Name
     'Eine Zweitverwertung - Abtrennen der Pfadangabe
     Neue_Datei_Name = ActiveWorkbook.Name
     
     'Übernehmen der Daten ins erste jungfräuliche Blatt
     'Ohne Kopieren was die Zwischenablage zerstört, und das kann ich gar nicht leiden.
     ''Das nennt man "Volle Referenzierung" - immer eindeutige 'Hausnummern'
     Set Ziel_Range = Workbooks(Neue_Datei_Name).Worksheets(1).Range(Workbooks(Neue_Datei_Name).Worksheets(1).Cells(4, 1), Workbooks(Neue_Datei_Name).Worksheets(1).Cells(Letzte_Zeile, 9))
     Set Quell_Range = Workbooks(Diese_Datei_Name).Worksheets(Dieses_Blatt).Range(Workbooks(Diese_Datei_Name).Worksheets(Dieses_Blatt).Cells(4, 1), Workbooks(Diese_Datei_Name).Worksheets(1).Cells(Letzte_Zeile, 9))
     'Das .Value ist hier wichtig
     Ziel_Range = Quell_Range.Value
     'Änderungen speichern und neue Mappe schließen (denke mal, das ist sinnvoll)
     ActiveWorkbook.Close (True)
     
    End Sub

Wenn ich dann den Code meinem Button zuweise, dann öffnet sich auch der Speichern Dialog und die neue Arbeitsmappe wird generiert. Diese ist aber leer und der Laufzeitfehler 1004 (Anwendungs- oder objektdefinierter Fehler) wird ausgeben und zwar laut dem Debugger auf folgender Code-Zeile:

  Set Quell_Range = Workbooks(Diese_Datei_Name).Worksheets(Dieses_Blatt).Range(Workbooks(Diese_Datei_Name).Worksheets(Dieses_Blatt).Cells(4, 1), Workbooks(Diese_Datei_Name).Worksheets(1).Cells(Letzte_Zeile, 9))

@Janush
Habe deine Testdatei auch mal ausprobiert. Funktioniert im Prinzip. Jedoch muss man immer selbst einen Bereich auswählen, was eigentlich nicht nötig ist, da der Bereich immer in einen bestimmten Bereich beginnt und dann in der "letzten ausgefüllten Zeile" endet. Außerdem werden überhaupt keine Formatierungen übernommen.

Wenn ich euch die Arbeit erleichtern kann, würde ich euch auch meine Datei schicken. Ich möchte die Daten nur hier nicht veröffentlichen.

Grüße, cheater

 

[Janush]

Also doch noch ned vorbei. Naja das mit der Formtierung liegt an dem .Value beim "Kopieren". Da müsste man die Zellformatierung mit übernehmen. Ich schau mal ob ich meine Datei dahin gehend anpassen kann.

Welchen Bereich willst Du kopieren? Einfach immer komplett bis zur letzten gefüllten Zeile? Kannst ja mal die Datei schicken, aber ich kann nichts versprechen.

 

[ds_cheater]

Hi,
sry wieder für die späte Antwort. Ich möchte ab Zeile 4 bis zu letzten gefüllten Zeile kopieren.

Grüße

 

[cumulonimbus8]

Könnte glatt sein, dass mein Code diese Margen im Auge hat.

Aber 8-ung: alle diese Tricks um «die letzte Zeile» [Spalte…] zu finden gehen effektiv davon aus, dass die Spalte in der ich das tue (bei mir A = 1) auch die ist die das unter(st)e Ende angibt. Bei lückenhaften Datensätzen sollte man (Datenbankdenken) die des Primärschlüssels wählen.
Technisch müsste man von der maximalen Zeile aus (gemäß XL-Version) oder einer sichern Obergrenze rückwärts zählen bis man einen Treffer hat - für jede Spalte. Auch RowsCount oder .End(xlUp).Row haben schon mal Murks abgeliefert, besonders neckisch war da UsedRange. Typisch XL, dass es alles Unmögliche kann aber bei solch Trivialen die Grätsche macht

CN8

 

[ds_cheater]

Hm,
also mein "eigener" Code funktioniert ja auch mit der xlUp-Methode. Ich schicke dir auch mal den Dropbox.Link.

Grüße

 

[Janush]

Hey Folks, also ich wuerde da nicht laenger rumtun. Bereich ist Spalte A - H, kopieren -> paste special values und formats. Danach im neuen File die ersten 3 Zeilen loeschen und fertig. Das zerstoert vielleicht die Zwischenablage, aber ich habe so das Gefuehl, dass das in diesem Fall nicht weiter schlimm ist :-)

Vielleicht werden ja nichtmal Formeln benutzt, dann braucht man nur einen Kopierbefehl fuer alles.

Also sowas wie:

Altes sheet Columns("A:H").Copy -> Neues sheet Range("A1").Paste
Neues sheet Rows(1:3).Delete

Schau mal ob Du es hinbekommst, ansonsten schau ich nochmal.

mfg