Datum finden und Bereich kopieren
18.04.2020 06:37:35
Daniel
Ich hoffe, dass ich hier auf folgende Problematik eine elegante Lösung finden kann.
Grundlage:
Ich arbeite an einem Planungstool in dem zwei verschiedene Datein bearbeitet werden,
1. Ein Kalender in dem für viele Bereiche eine Grobplanung erstellt wird.
Aufbau, Kalenderdatei mit Arbeitsblättern je Kalenderjahr
2. Eine Wochenplanung in dem für einen einzelnen Bereich eine Detailplanung erstellt wird
Aufbau, Datei je Bereich mit Arbeitsblatt je Monat mit entsprechenden Wochen.
Zielsetzung:
Ziel ist es mithilfe eines Makros den Wochenplan mit den aktuellen Kalenderinformationen zu befüllen um eine Tagesaktuelle Planungsgrundlage für die Detailplanung zu haben. Dazu soll ein Datum des Wochenplans als Referenz dienen.
Details:
Meine Idee des Vorgangs
1.) Referenzzelle in Wochenplanung Arbeitsblatt Januar nutzen und das Datum im Kalender finden
2.) Wenn Datum in Kalender gefunden, dann Bereich Markieren und kopieren
3.) In Zelle kopieren
4.) Vorgang für nächste Woche wiederholen
5.) Wenn Referenzzelle leer dann nichts tun (wichtig falls der Monat mit 4 statt 5 Wochen geplant wird)
Derzeit verwendeter Makro-Code
Muss für jede Bereichts-Datei und jeden Monat angepasst werden (Hauptnachteil)
____________________________________________________________________________
Sub Wochenplanung_Bereich1()
Range("C17:G24,C46:G53,C75:G82,C104:G111,C133:G140").Select
Selection.ClearContents
Selection.ClearComments
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Workbooks.Open Filename:=ThisWorkbook.Path & "\Kalender.xlsm"
Worksheets("Kalender 2020").Select
Range("H7:L14").Select
Selection.Copy
Windows("Wochenplanung.xlsm").Activate
Range("C17").Select
Selection.PasteSpecial paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
With Selection
.WrapText = False
.Orientation = 45
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
Windows("Kalender.xlsm").Activate
Range("O7:S14").Select
Selection.Copy
Windows("Wochenplanung.xlsm").Activate
Range("C46").Select
Selection.PasteSpecial paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
With Selection
.WrapText = False
.Orientation = 45
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
Windows("Kalender.xlsm").Activate
Range("V7:Z14").Select
Selection.Copy
Windows("Wochenplanung.xlsm").Activate
Range("C75").Select
Selection.PasteSpecial paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
With Selection
.WrapText = False
.Orientation = 45
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
Windows("Kalender.xlsm").Activate
Range("AC7:AG14").Select
Selection.Copy
Windows("Wochenplanung.xlsm").Activate
Range("C104").Select
Selection.PasteSpecial paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
With Selection
.WrapText = False
.Orientation = 45
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
Windows("Kalender.xlsm").Activate
Range("AJ7:AN14").Select
Selection.Copy
Windows("Wochenplanung.xlsm").Activate
Range("C133").Select
Selection.PasteSpecial paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
With Selection
.WrapText = False
.Orientation = 45
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
Range("B2").Select
Windows("102_QAP MASTER_V3.xlsm").Activate
Range("CJ35").Select
Selection.Copy
ActiveWindow.Close
End Sub
Schon Mal besten Dank im Voraus und auch für die vielen Antworten im Forum die mich schon deutlich weiter gebracht haben in meiner Arbeit!
Grüße Daniel
