vba , kann man den Plan jede Woche mit Inhalt unter dem alten Plan mit dem Inhalt (Formeln, Formatierung) kopieren?

Question

Hallo zusammen,

in der orginal Datei muss ich 15 Tabellenblätter ( 15 Abteilungen) vorbereiten. Ich muss jede kW neu anlegen und , die Spalten ,Zeilen neu anpassen, weil beim Einfügen doch nicht alles so bleibt,  wie es mal war.

Kann man irgendwie per VBA diese Pläne für jede Woche neu erstellen lassen?  Danke.

Bedanke mich im Voraus für die Hilfe.

https://supportnet.de/forum/?qa=blob&qa_blobid=8876231447499246334

Answer 1

Folgenden Code habe ich versucht. Er kopiert keine Tabellen, sondern den Text, und schriebt gleich unter dem gleichen Text .

Ich versuche die KW2-Tabelle unter die KW2-Tabelle zu kopieren, damit daraus eine KW3 wird. Nach KW3, soll KW4 usw. entstehen, aber nur bei Bedarf.

Sub KopierenUntereinander()
Dim i As Integer
With ActiveWorkbook

Set Rng = .Worksheets("Pack 1").UsedRange
Set rng1 = Worksheets("Pack 1").Cells(Rows.Count, "A").End(xlUp)(2)
Rng.Copy Destination:=rng1

End With
End Sub

Answer 2

Hallo zagor,

ich würde zum Kopieren einer neuen Kalenderwoche eine Vorlage erstellen, auf die zugegriffen wird. Du kannst das Tabellenblatt z.B. ausblenden, damit es nicht zu Irritationen kommt.

Ich habe dir mal hier deine Beispieldatei entsprechend bearbeitet: Download

Der Code kopiert die Vorlage immer in das aktuelle Blatt und passt die Kalenderwoche entsprechend an.

Beim Kopieren aus der Vorlage werden auch die Formatierungen mit übernommen. Die farbliche Unterlegung bei den Namen habe ich aus der Vorlage gelöscht. Aber die Vorlage kannst du ja nach deinen Bedürfnissen anpassen.

Hier auch noch der Code:

Sub neueKW()
Dim lngLetzte As Long
Dim wksQuelle As Worksheet

Set wksQuelle = ActiveSheet

'letzte beschriebene Zeile in Spalte C ermitteln
lngLetzte = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row

'Daten aus Vorlage kopieren
With Worksheets("Vorlage")
   .Range("B2:AD34").Copy
End With

'Daten in Arbeitsblatt einfügen
With wksQuelle
   .Activate
   .Range("B" & lngLetzte + 1).Select
   .Paste
   'Kopierbereich aufheben
   Application.CutCopyMode = False
   'Formel für Kalenderwoche einfügen
   .Range("D" & lngLetzte + 1).FormulaLocal = "=D" & lngLetzte - 32 & "+1"
End With

End Sub

Gruß

M.O.

Answer 3

Vielen Dank für die Unterstützung....

Answer 4

Guten Morgen @m-o,

wie kann man anschließend die ausgefüllte Vorlage ausdrucken? Sagen wir , ich  möchte die aktuellste Woche (die 27. Woche , somit die 27. Vorlage), die ich am Montag ausgefüllt habe ausdrucken. Wäre es auch möglich?

Bedanke mich im Voraus für die Hilfe....

Viele Grüße

Answer 5

Hallo zagor,

das folgende Makro druckt dir immer die letzte Woche in dem betreffenden Arbeitsblatt.

Sub drucken()
Dim lngLetzte As Long

With ActiveSheet
   'letzte beschriebene Zeile in Spalte C ermitteln
    lngLetzte = .Cells(Rows.Count, 3).End(xlUp).Row
    'Druckbereich auf letzte Woche festlegen
    .PageSetup.PrintArea = "$A$" & lngLetzte - 32 & ":$AD$" & lngLetzte
    'drucken
    .PrintOut Copies:=1
End With

End Sub

Der Ausdruck erfolgt auf dem Standarddrucker mit den Einstellungen, die du ggf. gemacht hast.

Gruß

M.O.

Answer 6

Sehr nett von Ihnen, besten Dank , ich werde es mal versuchen , ob ich die Exemplar-Anzahl des Ausdrucks über Inputbox hinbekomme.

Answer 7

Jetzt mit Inputbox für die Abfrage der Exemplar-Anzahl.  

Sub drucken()
Dim lngLetzte As Long
Dim IntAnz As Long

IntAnz = InputBox("Wieviele Kopien sollen gedruckt werden?")
With ActiveSheet
   'letzte beschriebene Zeile in Spalte C ermitteln
    lngLetzte = .Cells(Rows.Count, 3).End(xlUp).Row
    'Druckbereich auf letzte Woche festlegen
    .PageSetup.PrintArea = "$A$" & lngLetzte - 32 & ":$AD$" & lngLetzte
    'drucken
    .PrintOut Copies:=IntAnz
End With

End Sub

Answer 8

Guten Morgen @m-o,

ich komme zurück zu meinem ersten Beitrag unter dieser Frage. Die eigentliche Datei aus meinem ersten Beitrag hat 20 Arbeitsblätter. Die fünfzehn Schichtpläne plus vier Reserve-Schichtpläne sind in einer Datei. Zu diesen 19 Arbeitsblättern kommt noch der Anwesenheitsplaner der Abteilungen als Arbeitsblatt dazu. Somit hat die Datei 20 Arbeitsblätter. In den 15 Arbeitsblättern werden die Schichtpläne von ca.200 Mitarbeitern verwaltet. Ich habe aus der Datei eine xlsb-Datei gemacht, damit die Berechnungen schneller sind. Die eigentliche Datei ist zurzeit noch ca. 7000 KB groß. Die Größe ist nicht das Problem. Das Problem sind die Schichtpläne selber. Ich habe gezählt, jedes Arbeitsblatt hat 28.836 Funktionen (Formeln). Bei 19 Arbeitsblättern sind es 547.884 Funktionen. Deshalb braucht die Datei zum Öffnen oder zum Schließen geschlagene 15-28 Sekunden. Außerdem ist die Datei für das Simultan-Arbeiten von 6 Schichtführern, 3 Meistern und 3 Stellvertreter freigegeben.

Das war die Vorgeschichte.

Aus den oben genannten Gründen möchte ich die Daten in den Schichtplänen in einer separaten Datei archivieren. 

Ich versuche jetzt die Daten in eine andere Datei auszuschneiden, weil das Ausschneiden eine endgültige Angelegenheit ist, hatte ich meinen Versuch mit dem Kopieren der Werte gestartet. Dabei versuchte ich das Format des Originals beizubehalten, aber irgendwie kopieren der Werte in das original Format nicht machbar.  

Anschließend beabsichtige ich pro Arbeitsblatt nur drei Kalenderwochen in jedem Arbeitsblatt zu belassen, und somit die Datei leichter zu bekommen. Jedes Mal soll die entstandene vierte Kalenderwoche jedes Arbeitsblatts exportiert (archiviert) werden.

Ich darf die Daten nicht löschen, ich darf sie aber archivieren.

Deshalb füge ich die Beispieldatei aus meiner Frage diesmal mit drei Arbeitsblättern bei.

Ich wäre sehr dankbar, wenn Du eine Idee für mein Problem hast.

Beste Grüße

https://supportnet.de/forum/?qa=blob&qa_blobid=8226273569214718289

Hier ist der Code mit dem ich es versucht habe.

Code: 

Sub CopyFormat()
    Dim wbSource As Workbook
    Dim wbTarget As Workbook
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    
    ' Die Quellarbeitsmappe und das Arbeitsblatt festlegen
    Set wbSource = Workbooks.Open("F:\Abwesenheit\Plan_Neu.xlsm")
    Set wsSource = wbSource.Worksheets("Pack 1")
    
    ' Die Zielarbeitsmappe und das Arbeitsblatt festlegen
    Set wbTarget = Workbooks.Open("C:\Users\Zagor\Desktop\Kopie der Schichtpläne.xlsm")
    Set wsTarget = wbTarget.Worksheets("Pack1")
    
    ' Kopieren Sie das Format von der Quelle in das Zielarbeitsblatt
    wsSource.Range("G40:AC" & wsSource.Cells(wsSource.Rows.Count, "AC").End(xlUp).Row).Copy
    
    ' Kopieren die Werte von der Quelle in das Zielarbeitsblatt
    Sheets("Pack1").Cells(Rows.Count, 1).End(xlUp)(3).PasteSpecial (xlPasteFormats)
    Sheets("Pack1").Cells(Rows.Count, 1).End(xlUp)(3).PasteSpecial (xlPasteValues)
    
'    wsTarget.Range("A" & wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteFormats

'     ' Kopieren die Werte von der Quelle in das Zielarbeitsblatt
'    wsSource.Range("G40:AC" & wsSource.Cells(wsSource.Rows.Count, "AC").End(xlUp).Row).Copy
'    wsTarget.Range("A" & wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteValues
'
' ' Kopieren die Werte und das Format von der Quelle in das Zielarbeitsblatt
'    wsSource.Range("G40:AC" & wsSource.Cells(wsSource.Rows.Count, "AC").End(xlUp).Row).Copy
'    wsTarget.Range("A" & wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteAll

    
    ' Schließen die Arbeitsmappen, ohne die Änderungen zu speichern
'    wbSource.Close False
'    wbTarget.Close True
    
End Sub
 

Code:

Sub CopyValues()

    Dim wbSource As Workbook
    Dim wbTarget As Workbook
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    
    ' Die Quellarbeitsmappe und das Arbeitsblatt festlegen
    Set wbSource = Workbooks.Open("F:\Abwesenheit\Plan_Neu.xlsm")
    Set wsSource = wbSource.Worksheets("Pack 1")
    
    ' Die Zielarbeitsmappe und das Arbeitsblatt festlegen
    Set wbTarget = Workbooks.Open("C:\Users\Zagor\Desktop\Kopie der Schichtpläne.xlsm")
    Set wsTarget = wbTarget.Worksheets("Pack1")
    
     ' Kopieren die Werte von der Quelle in das Zielarbeitsblatt
    wsSource.Range("G40:AC" & wsSource.Cells(wsSource.Rows.Count, "AC").End(xlUp).Row).Copy
    wsTarget.Range("A" & wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteValues
    
      ' Schließen die Arbeitsmappen, ohne die Änderungen zu speichern
    wbSource.Close False
    wbTarget.Close True
    
End Sub

Answer 9

Hallo zagor,

mal ein anderer und einfacherer Ansatz: Einfach die Formeln in Werte umwandeln:

Sub Formeln_weg()

Dim rngZelle As Range

For Each rngZelle In Range("B2:AC34")
  If rngZelle.HasFormula Then rngZelle = rngZelle.Value
Next rngZelle

End Sub

Das ist nur mal ein grobes Beispiel für die 1. Kalenderwoche. Weniger Formeln, die zu berechnen sind, sollte die Speicherzeit reduzieren.

Das Kopieren von Werten und Formaten kannst du so machen:

Sub kopieren()
Dim wbTarget As Workbook

Set wbTarget = Workbooks.Open("C:\Users\Zagor\Desktop\Kopie der Schichtpläne.xlsm")

Range("B2:AC34").Copy

With Workbooks(wbTarget).Worksheets("Pack1").Range("A1")
 .PasteSpecial Paste:=xlPasteValues        'Werte
 .PasteSpecial Paste:=xlPasteFormats       'Formate
End With

'markierten Kopierbereich aufheben
Application.CutCopyMode = False

End Sub

Das ist natürlich nur ein einfacher Beispielcode mit deiner Zieltabelle.

Gruß

M.O.

Answer 10

Besten Dank, beide Optionen sind toll. Ich habe die Umwandlung der Formeln in zwei Arbeitsblättern getestet. Pro Arbeitsblatt dauerte die Umwandlung 3-4 Minuten.

Dann habe ich das Kopieren versucht. Ich musste Deine Formel etwas für mich anpassen, aber der Code hat wirklich bombastisch funktioniert. Ich versuche es seit zwei Tagen , aber mit Deinem Code ging es auf Anhieb. Danke Dir...

Jetzt muss ich ausschneiden probieren, denn ich möchte immer in jedem Arbeitsblatt 3 Kalenderwochen (Vorwoche, aktuelle, und kommende Woche) parat haben.