AW: aus daten im excel einen semesterkalender füllen
10.07.2016 14:53:22
fcs
Hallo Brugger,
das war eine Fleißarbeit um all die Rabdbedingungen sauber zu prüfen.
Ich hoffe das Ergebnis überzeugt.
Gruß
Franz
Sub Semesterplan()
Dim wksQuelle As Worksheet
Dim wksPlan As Worksheet
Dim ZeiQ As Long, ZeiQ1 As Long, ZeiQL
Dim ZeiP As Long
Dim SpaP As Long
Dim datStart As Date, datEnde As Date
Dim AnzSem As Integer
Dim colTeam As New Collection, strTeam As String
Dim rngZelle As Range
Dim varArt, strName As String, strVName As String, varSemester As Variant, intSem As _
Integer
On Error GoTo Fehler
Set wksQuelle = ActiveSheet 'oder Set wksQ = WOrksheets("Tabelle1")
Set wksPlan = ActiveWorkbook.Worksheets.Add(After:=wksQuelle)
With wksQuelle
ZeiQ1 = 2
ZeiQL = .Cells(.Rows.Count, 1).End(xlUp).Row
'Semester-Daten erfassen
datStart = Application.WorksheetFunction.Min(.Range(.Cells(ZeiQ1, 3), .Cells(ZeiQL, 6))) _
datEnde = Application.WorksheetFunction.Max(.Range(.Cells(ZeiQ1, 3), .Cells(ZeiQL, 6)))
AnzSem = (Year(datEnde) - Year(datStart)) * 2
'Namen der Teams erfassen ohne doppelte
For Each rngZelle In .Range(.Cells(ZeiQ1, 9), .Cells(ZeiQL, 14)).Cells
strTeam = rngZelle.Text
If Not (strTeam = "-" Or strTeam = "") Then
colTeam.Add strTeam, strTeam
End If
Next rngZelle
'Namen der Vorbereitungen ("Vorbereitung " & Art) als Team erfassen
For Each rngZelle In .Range(.Cells(ZeiQ1, 2), .Cells(ZeiQL, 2)).Cells
If IsDate(rngZelle.Offset(0, 1)) Then
strTeam = "Vorbereitung " & rngZelle.Text
colTeam.Add strTeam, strTeam
End If
Next rngZelle
End With
With wksPlan
.Cells.VerticalAlignment = xlTop
.Cells.WrapText = True
'Spalten und Zeilentitel eintragen
.Cells(1, 1) = "Semester"
.Cells(1, 2) = "Begin"
.Cells(2, 1) = "Team"
.Cells(2, 2) = "Ende"
'Fenster fixieren
.Range("C3").Select
ActiveWindow.FreezePanes = True
'Team-Namen eintragen und sortieren
For ZeiP = 1 To colTeam.Count
.Cells(ZeiP + 2, 1) = colTeam(ZeiP)
Next
With .Range(.Cells(3, 1), .Cells(colTeam.Count + 2, 1))
.Sort key1:=.Range("A1"), order1:=xlAscending, Header:=xlNo
End With
'Semster-Begin/Ende eintragen bzw. berechnen
.Cells(1, 3) = datStart
.Range(.Cells(1, 4), .Cells(1, 3 + AnzSem - 1)).FormulaR1C1 = _
"=DATE(YEAR(RC[-1]),MONTH(RC[-1])+6,1)"
.Range(.Cells(2, 3), .Cells(2, 3 + AnzSem - 1)).FormulaR1C1 = _
"=DATE(YEAR(R[-1]C),MONTH(R[-1]C)+6,0)"
With .Range(.Cells(1, 3), .Cells(2, 3 + AnzSem - 1))
.Value = .Value
End With
.Columns(1).ColumnWidth = 14
.Range(.Cells(1, 3), .Cells(2, 3 + AnzSem - 1)).EntireColumn.ColumnWidth = 50
End With
With wksQuelle
'Namen abarbeiten
For ZeiQ = ZeiQ1 To ZeiQL
varArt = .Cells(ZeiQ, 2).Text
strName = .Cells(ZeiQ, 8).Text: strVName = .Cells(ZeiQ, 7).Text
varSemester = .Range(.Cells(ZeiQ, 9), .Cells(ZeiQ, 14))
'Prüfen ob es einen Vorbereitungszeitraum gibt
If IsDate(.Cells(ZeiQ, 3)) Then
strTeam = "Vorbereitung " & varArt
datStart = .Cells(ZeiQ, 3)
datEnde = .Cells(ZeiQ, 4)
AnzSem = (Year(datEnde) - Year(datStart)) * 2
'Zeile mit Team
ZeiP = Application.Match(strTeam, wksPlan.Range("A:A"), 0)
'Spalte mit Semester-Beginn
SpaP = fncSpa(wks:=wksPlan, Zeile:=1, varWert:=datStart)
Do
With wksPlan.Cells(ZeiP, SpaP)
If .Text = "" Then
.Value = strName & ", " & strVName
Else
.Value = .Text & Chr(10) & strName & ", " & strVName
End If
End With
AnzSem = AnzSem - 1
SpaP = SpaP + 1
Loop Until AnzSem = 0
End If
datStart = .Cells(ZeiQ, 5)
datEnde = .Cells(ZeiQ, 6)
AnzSem = (Year(datEnde) - Year(datStart)) * 2
'Spalte mit Beginn 1. Semester
SpaP = fncSpa(wks:=wksPlan, Zeile:=1, varWert:=datStart)
For intSem = 1 To UBound(varSemester, 2)
strTeam = varSemester(1, intSem)
If Not (strTeam = "-" Or strTeam = "") Then
'Zeile mit Team
ZeiP = Application.Match(strTeam, wksPlan.Range("A:A"), 0)
With wksPlan.Cells(ZeiP, SpaP + intSem - 1)
If .Text = "" Then
.Value = strName & ", " & strVName & " (" & varArt & ")"
Else
.Value = .Text & Chr(10) & strName & ", " & strVName & " (" & _
varArt & ")"
End If
End With
End If
AnzSem = AnzSem - 1
If AnzSem = 0 Then Exit For
Next intSem
Next ZeiQ
End With
With wksPlan
With .Range(.Rows(2), .Rows(.Cells(.Rows.Count, 1).End(xlUp).Row))
.EntireColumn.AutoFit
.AutoFit
End With
End With
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case 457 'doppelter Collection-Eintrag
Resume Next
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub
Function fncSpa(wks As Worksheet, Zeile As Long, varWert) As Long
Dim Spalte As Long
With wks
For Spalte = 1 To .Cells(Zeile, .Columns.Count).End(xlToLeft).Column
If .Cells(Zeile, Spalte).Value = varWert Then
fncSpa = Spalte
End If
Next
End With
End Function