Zeiträume in horiz.Kalender übertragen

Hallo,
zur folgender Problemstellung bräuchte ich etwas Nachhilfe: Ich möchte Zeiträume (ähnlich wie bei einem Urlaubskalender) in einen horizontalen Kalender übertragen. Dazu habe ich eine Mappe mit den Tabellenblättern "Quelle" und "Ziel".
Das Tabellenblatt Quelle enthält in Spalte A Projektnummern, z.B. 4721, und in den Spalten C und D das Start- und Enddatum. In Spalte E steht die Maßnahme, z.B. "ABC". Nun soll die Projektnummer im Blatt "Ziel" gesucht werden und "ABC" in jeden Tag des Kalenders eintragen werden, wenn sie in diesem Zeitraum liegen.
Sollte der Kalender nicht alle Zeiträume vollständig abdecken, soll er eben nur bis zum Ende gefüllt werden.
Ich habe einen Ansatz gefunden in einem Forum; er ist mir allerdings nicht so verständlich, als dass ich ihn hätte anpassen können (http://www.office-loesung.de/ftopic294692_0_0_asc.php; die Datei ließ sich ebenfalls z.Zt. nicht herunterladen.
Im Voraus vielen Dank für Tipps oder Unterstützung.
https://www.herber.de/bbs/user/136363.xlsx
Grüße, Constantin

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub Uebertragen() Dim LoLetzte As Long Dim LoI As Long Dim RaFound As Range Dim LoAnfang Dim LoEnde With Worksheets("Quelle") LoLetzte = IIf(IsEmpty(.Cells(Rows.Count, 1)), _ .Cells(Rows.Count, 1).End(xlUp).Row, .Rows.Count) For LoI = 2 To LoLetzte Set RaFound = Worksheets("Ziel").Columns(1).Find(.Cells(LoI, 1), _ .Range("A1"), , xlPart, , xlNext) ' xlPart enthalten ' xlWhole kompletter Vergleich If Not RaFound Is Nothing Then LoAnfang = Application.Match(.Cells(LoI, 3), Worksheets("Ziel").Rows(1), 0) LoEnde = Application.Match(.Cells(LoI, 4), Worksheets("Ziel").Rows(1), 0) If Not IsError(LoAnfang) Or Not IsError(LoEnde) Then With Worksheets("Ziel") ' vorhandene löschen .Range(.Cells(RaFound.Row, 2), _ .Cells(RaFound.Row, 16384)).ClearContents .Range(.Cells(RaFound.Row, LoAnfang), _ .Cells(RaFound.Row, LoEnde)) = Worksheets("Quelle").Cells(LoI, 5) End With Else MsgBox "Datum nicht gefunden" End If End If Next LoI End With End Sub

Hallo Constatin,
ungestetet.

Option Explicit
Sub Uebertragen()
Dim LoLetzte As Long
Dim LoI As Long
Dim RaFound As Range
Dim LoAnfang
Dim LoEnde
With Worksheets("Quelle")
LoLetzte = IIf(IsEmpty(.Cells(Rows.Count, 1)), _
.Cells(Rows.Count, 1).End(xlUp).Row, .Rows.Count)
For LoI = 2 To LoLetzte
Set RaFound = Worksheets("Ziel").Columns(1).Find(.Cells(LoI, 1), _
.Range("A1"), , xlPart, , xlNext)
' xlPart enthalten
' xlWhole kompletter Vergleich
If Not RaFound Is Nothing Then
LoAnfang = Application.Match(.Cells(LoI, 3), Worksheets("Ziel").Rows(1), 0)
LoEnde = Application.Match(.Cells(LoI, 4), Worksheets("Ziel").Rows(1), 0)
If Not IsError(LoAnfang) Or Not IsError(LoEnde) Then
With Worksheets("Ziel")
' vorhandene löschen
.Range(.Cells(RaFound.Row, 2), _
.Cells(RaFound.Row, 16384)).ClearContents
.Range(.Cells(RaFound.Row, LoAnfang), _
.Cells(RaFound.Row, LoEnde)) = Worksheets("Quelle").Cells(LoI, 5)
End With
ElseIf IsError(LoAnfang) Or IsError(LoEnde) Then
With Worksheets("Ziel")
LoLetzte = IIf(IsEmpty(.Cells(1, .Columns.Count)), Cells(1, _
.Columns.Count).End(xlToLeft).Column, .Columns.Count)
' vorhandene löschen
.Range(.Cells(RaFound.Row, 2), _
.Cells(RaFound.Row, 16384)).ClearContents
.Range(.Cells(RaFound.Row, LoAnfang), _
.Cells(RaFound.Row, loletze)) = Worksheets("Quelle").Cells(LoI, 5)
End With
Else
MsgBox "Datum nicht gefunden"
End If
End If
Next LoI
End With
End Sub

Gruß Hajo

Beliebteste Forumthreads (12 Monate)

Zeiträume in horiz.Kalender übertragen

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

200 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zeiträume in horiz.Kalender übertragen

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

200 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread