AW: Exel Kalender abgleichen
30.10.2010 05:53:42
fcs
Hallo Beat,
ich hatte auch schon begonnen, eine Lösung zu erstellen. Hier das fertige Produkt inklusive Wertabfrage und Zellformatierung.
Ich war bei meiner Programmierung davon ausgegangen, dass der Zeilenaufbau in den beiden Tabellenblättern nicht identisch ist. Deshalb ist die Suche nach der Zeile im Zielblatt etwas komplizierter gestaltet als bei Christian.
Mit meiner Version kannst du im Blatt "Abwesenheiten" auch mehrere Zellen ausfüllen, z.B. per Kopieren oder Auffüllen.
Gruß
Franz
'Code im Tabellen-Modul Blatt Abwesenheiten
Option Explicit
Private sName As String, dDatum As Date, vEintrag, vVorhanden, dMonat As Date
Private Zeile_A As Long, Spalte_A As Long
Private Zeile_P As Long, Spalte_P As Long
Private wks_Plan As Worksheet, wks_Abw As Worksheet, rZelle As Range
Private ZielZelle As Range
Private msgText As String, msgTitel As String
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Zeile As Long
'Alle geänderten Zellen ändern
For Each rZelle In Target
Zeile_A = rZelle.Row
Spalte_A = rZelle.Column
Set wks_Abw = Worksheets("Abwesenheiten")
Set wks_Plan = Worksheets("Planung")
'Spalten-/Zeilenbereich in dem Eingaben geprüft werden sollen
If Spalte_A > 3 And Spalte_A 2 Then
'Wert in Spalte C der Eingabe Zeile prüfen
Select Case wks_Abw.Cells(Zeile_A, 3).Value
Case "" 'kein Eintrag (Name oder sonstiges) in Spalte C vorhanden
With wks_Abw.Cells(Zeile_A, 3)
'Prüfen, ob Leerzeile oberhalb oder unterhalb Monatszeile
If IsDate(.Offset(-2, 0)) Or IsDate(.Offset(-1, 0)) Or IsDate(.Offset(1, 0)) Then
'do nothing
Else
MsgBox "In Spalte C der Eingabezeile steht noch kein Name!", _
vbInformation + vbOKOnly
End If
End With
Case "Kalenderwoche", "Datum", "Wochentag"
'do nothing - Änderungen in Zeilen die nicht ins Zielblatt sollen
Case Else
If IsDate(wks_Abw.Cells(Zeile_A, 3).Value) Then
'do nothing - Zeile mit Monatsdatum
Else
'Eingabedaten merken/ermitteln
vEintrag = rZelle.Value
sName = wks_Abw.Cells(Zeile_A, 3).Value
Zeile = Zeile_A
Do Until wks_Abw.Cells(Zeile, 3) = "Datum"
Zeile = Zeile - 1
Loop
dDatum = wks_Abw.Cells(Zeile, Spalte_A).Value
dMonat = wks_Abw.Cells(Zeile, 3).Offset(-3, 0).Value
Call Eintragen
End If
End Select
End If
Next
Set wks_Plan = Nothing: Set wks_Abw = Nothing: Set rZelle = Nothing: Set ZielZelle = Nothing
End Sub
Private Sub Eintragen()
'Eingabe im Blatt "Plandaten" eintragen
Dim Zeile As Long, rSuchen As Range, rSuchbereich As Range
With wks_Plan
'Zeile mit Monatsdatum in Spalte C suchen
For Zeile = 1 To .Cells(.Rows.Count, 3).End(xlUp).Row
If IsDate(.Cells(Zeile, 3).Value) Then
If .Cells(Zeile, 3).Value = dMonat Then
'Bereich mit Namen für gefundenen Monat
With .Cells(Zeile, 3)
Set rSuchbereich = wks_Plan.Range(.Offset(5, 0), .Offset(23, 0))
End With
'Name suchen
Set rSuchen = rSuchbereich.Find(What:=sName, LookIn:=xlValues, lookat:=xlWhole)
If rSuchen Is Nothing Then
msgText = sName & " im Monat " & Format(dMonat, "MMMM") & " noch nicht vorhanden!"
msgText = msgText & vbLf & vbLf & "Name """ & sName & """ eintragen?"
If MsgBox(msgText, vbYesNo, "Neuer Name im Ziel-Monat") = vbYes Then
'Name eintragen
Zeile_P = .Cells(Zeile, 3).Offset(23, 0).End(xlUp).Row + 1
wks_Plan.Cells(Zeile_P, 3).Value = sName
Else
GoTo Beenden
End If
Else
Zeile_P = rSuchen.Row
End If
Spalte_P = Spalte_A
Set ZielZelle = wks_Plan.Cells(Zeile_P, Spalte_P)
'vorhandenen Wert einlesen
vVorhanden = ZielZelle.Value
'vorhandenen Wert prüfen
If IsEmpty(ZielZelle) Then
ZielZelle = vEintrag
Else
Select Case vVorhanden
Case "" 'Leerstring in Zelle
ZielZelle = vEintrag
Case Else
If fncMsgBox() = False Then GoTo Beenden
End Select
End If
Call Zielzelle_Formatieren
Exit For
End If
End If
Next
Beenden:
End With
End Sub
Private Function fncMsgBox() As Boolean
msgTitel = "Datum: " & Format(dDatum, "DD.MM.YYYY") & " - Name: " & sName
msgText = "Es ist schon ein Wert eingetragen" & vbLf
msgText = msgText & " aktueller Wert: " & vVorhanden & vbLf _
& " neuer Wert: " & vEintrag & vbLf
msgText = msgText & "Soll alter Wert überschrieben werden?"
If MsgBox(msgText, vbQuestion + vbYesNo, msgTitel) = vbYes Then
ZielZelle.Value = vEintrag
fncMsgBox = True
Else
fncMsgBox = False
End If
End Function
Private Sub Zielzelle_Formatieren()
'Zielzelle Formatieren
With ZielZelle
Select Case .Value
Case ""
.Interior.ColorIndex = xlColorIndexNone
Case 1
.Interior.Color = 16711680 'vbBlue
Case 2
.Interior.Color = 65535 'vbGelb
Case 3
.Interior.Color = 16776960 'vbCyan
Case 4
.Interior.Color = 16711935 'vvbMagenta
Case Else
.Interior.ColorIndex = xlColorIndexNone
End Select
End With
End Sub