AW: Text aus mehreren Tabellenblättern lesen
04.12.2012 05:10:36
fcs
Hallo hachi,
man kann die Information in den Monatsblättern per Formel auswerten:
Tabellenblattname: Urlaubsliste
Formel in Zelle D4:
=WENN(ODER($A4=0;$A4="");"";WENN(LINKS(INDEX(INDIREKT(TEXT(D$1;"MMMM")
&"!J9:AN1000");VERGLEICH($A4;INDIREKT(TEXT(D$1;"MMMM")
&"!E9:E1000");0)-2;VERGLEICH(D$1;INDIREKT(TEXT(D$1;"MMMM")
&"!J8:AN8");0));1)="U";"U";""))
Diese Formel kannst du nach rechts und unten kopieren.
Das ist aber relativ rechenintensiv.
Deshalb ist es ggf. effektiver, die Urlaubsliste bei Bedarf per Makro zu aktualisieren.
Nachfolgend eine entsprechendes Makro.
Gruß
Franz
Option Explicit
Sub Urlaubsliste()
Dim wksUrlaub As Worksheet
Dim wksMonat As Worksheet
Dim varPNr
Dim datDatum As Date
Dim Zeile_U As Long, Spalte_U As Long
Dim Zeile_M As Long, Spalte_M As Long
Dim varEintrag
Dim ZellePNr As Range
Dim StatusCalc
Set wksUrlaub = Worksheets("Urlaubsliste")
On Error GoTo Fehler
'Makrobremsen lösen
With Application
.EnableEvents = False
StatusCalc = .Application.Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With wksUrlaub
'Altdaten löschen
Zeile_U = .Cells(.Rows.Count, 1).End(xlUp).Row
Spalte_U = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(4, 4), .Cells(Zeile_U, Spalte_U)).ClearContents
'Datumswerte in Zeile 1 abarbeiten
For Spalte_U = 4 To .Cells(1, .Columns.Count).End(xlToLeft).Column
datDatum = .Cells(1, Spalte_U).Value
If fncCheckSheet(Format(datDatum, "MMMM")) = True Then
Set wksMonat = Worksheets(Format(datDatum, "MMMM"))
'Spalte mit Datum im Monatsblatt
Spalte_M = Day(datDatum) + 9
'PNr in Spalte A abarbeiten
For Zeile_U = 4 To .Cells(.Rows.Count, 1).End(xlUp).Row
varPNr = .Cells(Zeile_U, 1).Value
If varPNr > 0 Then
varEintrag = ""
With wksMonat
'PNr in Spalte E des Monatsblattes suchen
With .Range(.Cells(9, 5), .Cells(.Rows.Count, 5))
Set ZellePNr = .Find(What:=varPNr, LookIn:=xlValues, lookat:=xlWhole)
End With
If Not ZellePNr Is Nothing Then
Zeile_M = ZellePNr.Row - 2 'Zeile mit Nachname
varEintrag = .Cells(Zeile_M, Spalte_M).Value
Select Case varEintrag
Case "U", "u", "U6", "u6"
wksUrlaub.Cells(Zeile_U, Spalte_U).Value = "U"
End Select
End If
End With 'wksMonat
End If
Next Zeile_U
End If
Next Spalte_U
End With 'wksUrlaub
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, _
vbInformation + vbOKOnly, "Makro: Urlaubsliste"
End Select
End With
'Makrobremsen zurücksetzen
With Application
.EnableEvents = True
.Calculation = StatusCalc
.ScreenUpdating = True
End With
Set ZellePNr = Nothing: Set wksUrlaub = Nothing: Set wksMonat = Nothing
End Sub
Function fncCheckSheet(strBlattname, Optional wbk As Workbook) As Boolean
'Prüft, ob Blatt in Arbeitsmappe vorhandem
Dim objSheet As Object
On Error GoTo Fehler
If wbk Is Nothing Then Set wbk = ActiveWorkbook
fncCheckSheet = False
Set objSheet = wbk.Sheets(strBlattname)
fncCheckSheet = True
Fehler:
End Function