Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1664to1668
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Arbeitsblatt in neuer Mappe abspeichern

Arbeitsblatt in neuer Mappe abspeichern
29.12.2018 18:38:53
Michael
Hallo
Habe gerade in einem anderen Beitrag eine ähnliche Anfrage gelesen, die aber nicht so ganz zu meinem Anliegen passt.
Ich möchte aus einer Mappe die Tabelle1 (Bereich A3:U500) in einer neu zu erzeugenden Mappe abspeichern und schließen.
Der Speicherort der neuen Mappen ist immer der gleiche (Fast): Server:\Daten\Lager\Listen\Bestand\(Jetzt den Ordner mit der aktuellen Jahreszahl wählen)
Das Bedeutet: noch haben wir 2018, also diesen. In 3 Tagen den 2019er Ordner usw. Ein Ordner mit entsprechender Jahreszahl ist dann vorhanden.
Der Dateiname soll folgendermaßen aussehen z.B.: Bremen KW 01_1.xlsx
"KW ?" im Namen, soll sich vom Datum her selbstständig ableiten, und "_1" soll eine fortlaufende Nummerierung sein. (Falls die Datei mehrmals in einer Woche gespeichert wird) Das heißt es muss vor dem abspeichern erst nachgeschaut werden ob "_1" schon vorhanden ist, wenn ja dann "_2" usw.
Der abzuspeichernde Bereich (Ist nur ein Teil der Tabelle1) soll alle Formatierungen beibehalten, also Zellengrößen, Schriftarten, Rahmen und Farben. ABER Formelergebnisse nur als Werte eintragen.
Ich hoffe das ich alles so gut wie möglich beschrieben habe.
Vielen Dank für eure Hilfe
Michael

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Arbeitsblatt in neuer Mappe abspeichern
29.12.2018 19:57:12
UweD
Hallo
so...
Modul1
Option Explicit 
 
Sub kopieren() 
    Dim Pfad As String, Pre As String, Datei As String, Ext As String 
    Dim Jahr As Integer, KW As String, Lnr As Integer 
    Dim TB1, TB2, WB2, Rng As String 
     
    Set TB1 = ActiveWorkbook.Sheets("Tabelle1") 
    Rng = "A3:U500" 
     
    Pre = "Bremen " 
     
    Pfad = "Server:\Daten\Lager\Listen\Bestand\" 'mit \ am Ende 
    'Pfad = "X:\Temp\Test\" 'zum Testen 
    Jahr = Year(Date) 
     
    'Verzeichnis vorhanden? 
    If Dir(Pfad & Jahr, vbDirectory) = "" Then 
        MsgBox "Verzeichnis '" & Pfad & Jahr & "' fehlt" 
        Exit Sub 
    End If 
     
    Ext = ".xlsx" 
    KW = "KW " & WorksheetFunction.WeekNum(Date, 11) & "_" 
     
    Do 
        Lnr = Lnr + 1 
        Datei = Pfad & Jahr & "\" & Pre & KW & Lnr & Ext 
    Loop Until Dir(Datei) = "" 
     
    'Blatt in neue Datei kopieren 
    TB1.Copy 
    Set WB2 = ActiveWorkbook 
    Set TB2 = WB2.Sheets(1) 
     
    'Alles löschen außer Formate 
    TB2.Cells.ClearContents 
     
    'Werte des Bereicht übertragen 
    TB2.Range(Rng).Value = TB1.Range(Rng).Value 
     
    'Speichern und schließen 
    WB2.SaveAs Filename:=Datei, FileFormat:=xlOpenXMLWorkbook 
    WB2.Close 
 
     
End Sub 

LG UweD
Anzeige
AW: Arbeitsblatt in neuer Mappe abspeichern
30.12.2018 17:44:58
Michael
Hallo Uwe
Vielen Dank für deine Hilfe. Entschuldige das ich mich erst so spät zurück melde, ich bin erst heute nachmittag wieder nach Hause gekommen.
Habe deinen Code ausprobiert. Die Dateinamen-Generierung funktioniert einwandfrei, auch die Pfad-Erkennung und Kontrolle klappt.
Das einzige was nicht so ist wie angestrebt, ist das kopieren. Ziel ist, das der neue Sheet in der neuen Mappe, nur den angegebenen Bereich enthält. In deinem Code wird aber der ganze Sheet kopiert, dann alle Einträge gelöscht und der angegebene Bereich wieder als Werte eingetragen.
Es soll im neuen Sheet nichts weiter als der angegebene Bereich erscheinen. Beim ausprobieren hat mich Windows dann auch noch darauf hingewieden das beim Abspeichern als .xlsx keine Makros übernommen werden können und ob ich nicht lieber als xlsm abspeichern möchte. Lässt sich diese Abfrage umgehen? Es soll nur eine abgespeicherte Liste sein, ohne Formeln und Makros.
Kannst du bitte nochmals über deinen Code rüberschauen und ihn anpssen?
Vielen Dank und Gruß
Michael
Anzeige
AW: Arbeitsblatt in neuer Mappe abspeichern
30.12.2018 18:23:25
UweD
Hallo
Wenn ich nur ein Sheet kopiere, dann müssen ja Makros im Codebereich der Tabelle vorhanden sein.
Abhilfe wäre dann z. B.
erst wie neue Datei anzulegen,
dann nur den Bereich dann komplett zu kopieren
und dann die Formeln in Werte umzuwandeln.
Um das zu testen, wäre die (abgesteckte) Original Datei sinnvoll.
Lade die doch mal hoch.
LG UweD
AW: Arbeitsblatt in neuer Mappe abspeichern
30.12.2018 21:36:16
Michael
Hallo Uwe
Hat eine Weile gedauert bis die Beispielmappe erstellt war. Aber hier ist sie.
https://www.herber.de/bbs/user/126405.xlsm
Der Bereich hat sich etwas geändert, die Formeln sind vereinfacht, und ein paar CommandButtons sind auch drin. Im TabellenBlatt Code sind Zeilensprünge hinterlegt. All das wird in der Neuen Mappe nicht benötigt, Nur die Formatierung der Tabelle (Form,Farbe,Größe) und alle Einträge und Formelergebnisse innerhalb des Bereichs, sollen als Werte erscheinen.
Viele Grüße
Michael
Anzeige
AW: Arbeitsblatt in neuer Mappe abspeichern
31.12.2018 10:55:00
UweD
Hallo nochmal
dann so....
Sub kopieren()
    Dim Pfad As String, Pre As String, Datei As String, Ext As String
    Dim Jahr As Integer, KW As String, Lnr As Integer
    Dim TB1, TB2, WB2, Rng As String
     
    Set TB1 = ActiveWorkbook.Sheets("Verteilung")
    Rng = "A4:U500"
     
    Pre = "Bremen "
     
    Pfad = "Server:\Daten\Lager\Listen\Bestand\" 'mit \ am Ende 
    Pfad = "X:\Temp\Test\" 'zum Testen 
    Jahr = Year(Date)
     
    'Verzeichnis vorhanden? 
    If Dir(Pfad & Jahr, vbDirectory) = "" Then
        MsgBox "Verzeichnis '" & Pfad & Jahr & "' fehlt"
        Exit Sub
    End If
     
    Ext = ".xlsx"
    KW = "KW " & WorksheetFunction.WeekNum(Date, 11) & "_"
     
    Do
        Lnr = Lnr + 1
        Datei = Pfad & Jahr & "\" & Pre & KW & Lnr & Ext
    Loop Until Dir(Datei) = ""
     
    'Neue Datei 
    Set WB2 = Workbooks.Add
    Set TB2 = WB2.Sheets(1)
     
    'Bereich kopieren 
    TB1.Range(Rng).Copy
    With TB2.Range(Rng)
        .PasteSpecial Paste:=xlPasteAllUsingSourceTheme
        .PasteSpecial Paste:=xlPasteColumnWidths
        .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    End With
    Application.CutCopyMode = False
     
    'Speichern und schließen 
    WB2.SaveAs Filename:=Datei, FileFormat:=xlOpenXMLWorkbook
    WB2.Close
      
End Sub
Noch ein Tipp
anstelle von
If Target.Cells.Address = "$U$7" Then Range("B29").Select
If Target.Cells.Address = "$U$8" Then Range("B30").Select
If Target.Cells.Address = "$U$9" Then Range("B31").Select
'.... 
If Target.Cells.Address = "$U$549" Then Range("B571").Select
If Target.Cells.Address = "$U$550" Then Range("B572").Select
If Target.Cells.Address = "$U$551" Then Range("B573").Select
If Target.Cells.Address = "$U$557" Then MsgBox AC & "  Verteilung beendet"
If Target.Cells.Address = "$U$558" Then MsgBox AC & "  Verteilung beendet"
'.... 
If Target.Cells.Address = "$U$571" Then MsgBox AC & "  Verteilung beendet"
If Target.Cells.Address = "$U$572" Then MsgBox AC & "  Verteilung beendet"
If Target.Cells.Address = "$U$573" Then MsgBox AC & "  Verteilung beendet"

reicht das.
Microsoft Excel Objekt Tabelle1
Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
    On Error GoTo Fehler 
     
    If Not Intersect(Range("U7:U551"), Target) Is Nothing Then 
        Application.EnableEvents = False 
        Target.Offset(22, -19).Select 
        Application.EnableEvents = True 
    End If 
     
    If Not Intersect(Range("U557:U573"), Target) Is Nothing Then 
        MsgBox AC & "  Verteilung beendet" 
    End If 
    
    '*** Fehlerbehandlung 
    Err.Clear 
Fehler: 
    Application.EnableEvents = True 
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear 
End Sub 
 

LG UweD
Anzeige
AW: Arbeitsblatt in neuer Mappe abspeichern
31.12.2018 16:28:32
Michael
Hallo Uwe
Dein überarbeiteter Code zum speichern, läuft jetzt Perfekt. Genau so wie ich ihn mir vorgestellt habe. Vielen Dank dafür.
Eine Frage aber noch dazu: Als ich den Code ausgeführt habe hat er mir eine Datei mit Namen
"Bremen KW 53_1" abgespeichert. Es gibt aber dieses Jahr keine KW 53. Heute ist schon KW 01. Das mag jetzt kleinlich sein, und ein Umbenennen von Hand, ist in diesem Fall auch nicht Umständlich. Aber, generiert der Code ab 01.01. dann KW 01 oder 54? Ist das abhängig vom Datum, oder woran orientiert sich die KW Zahl?
Zu deiner "Zusatzarbeit" Worksheet_SelectionChange
Der Code der in Mappe war, ist veraltet. Habe in meinen Original Mappen schon einen Einzeiler stehen.
Ähnlich diesem:
If Target.Column = 19 And Target.Row >= 7 And Target.Row Dein Code gefällt mir aber auch gut, vorallem wegen der MsgBoxen und der Fehlerbehandlung. Sowas habe ich eh viel zu wenig.
Vielen Dank und Grüße
Michael
Anzeige
AW: Arbeitsblatt in neuer Mappe abspeichern
31.12.2018 17:25:45
UweD
Hallo
OK. Aus der 11 in dieser Zeile muss die 21 werden, dann wird die Deutsche Norm für Kalenderwochen angewendet.
KW = "KW " & WorksheetFunction.WeekNum(Date, 11) & "_"
KW = "KW " & WorksheetFunction.WeekNum(Date, 21) & "_"
Guten Rutsch, UweD
AW: Arbeitsblatt in neuer Mappe abspeichern
31.12.2018 17:42:44
Michael
Besten Dank
Wünsche dir ebenfalls einen guten Rutsch und ein zufriedenes 2019
Michael

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige