Arbeitsblatt in neuer Mappe abspeichern

Forumthread: 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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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

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

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

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

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

Beliebteste Forumthreads (12 Monate)

Arbeitsblatt in neuer Mappe abspeichern

Forumthread: Arbeitsblatt in neuer Mappe abspeichern

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

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread