AW: Monatsdaten in Jahresübersicht
18.08.2010 07:43:43
fcs
Hallo Hans,
bei solchen Jahresübersichten mit variablen Zeilen je Monat sollte man immer die kommplette Übersicht per Makro neuerstellen.
Nachfolgend ein Beispiel, in dem du die Tabellennamen, die Startzelle in den Monatsblättern für den Vergleich und die 1. Zeile in der Übersicht noch anpassen muss.
Gruß
Franz
Option Explicit
'Code in einem allgemeinen Modul
Private wksUeber As Worksheet
Private Zeile As Long
Private Const sStartZelle As String = "B5" '1. zu prüfende Zelle in den Monatsblättern
Private Const Zeile1 = 5 'Zeile in Übersicht in der Januar beginnen soll
Sub JahresUebersicht()
Dim iIndex As Long, StatusCalc As Long
Set wksUeber = Worksheets("Übersicht") 'Namen des Übersichtsblatts ggf. anpassen
'Einstellungen der Anwendung zur Beschleunigung der Makroausführung
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
If StatusCalc xlCalculationManual Then .Calculation = xlCalculationManual
End With
'Altdaten in Übersicht löschen
With wksUeber
Zeile = .Cells.SpecialCells(xlCellTypeLastCell).Row
If Zeile >= Zeile1 Then
With .Range(.Rows(Zeile1), .Rows(Zeile))
.ClearContents
.Font.Bold = False
End With
End If
End With
Zeile = Zeile1 'Zeilenzähler setzen
'12 Monatsblätter abarbeiten
For iIndex = 1 To 12
Select Case iIndex
Case 1: Call Monat(sMonat:="Januar", sBlattname:="Januar")
Case 2: Call Monat(sMonat:="Februar", sBlattname:="Februar")
Case 3: Call Monat(sMonat:="März", sBlattname:="März")
Case 4: Call Monat(sMonat:="April", sBlattname:="April")
Case 5: Call Monat(sMonat:="Mai", sBlattname:="Mai")
Case 6: Call Monat(sMonat:="Juni", sBlattname:="Juni")
Case 7: Call Monat(sMonat:="Juli", sBlattname:="Juli")
Case 8: Call Monat(sMonat:="August", sBlattname:="August")
Case 9: Call Monat(sMonat:="September", sBlattname:="September")
Case 10: Call Monat(sMonat:="Oktober", sBlattname:="Oktober")
Case 11: Call Monat(sMonat:="November", sBlattname:="November")
Case 12: Call Monat(sMonat:="Desember", sBlattname:="Dezember")
End Select
Next
'Einstellungen der Anwendung zurücksetzen
With Application
.ScreenUpdating = True
If StatusCalc .Calculation Then .Calculation = StatusCalc
End With
MsgBox "Jahresübersich ist aktualisiert"
End Sub
Private Sub Monat(sMonat As String, sBlattname As String)
'Werte im Monatsblatt prüfen und in Jahresübersicht übertragen
Dim ZelleStart As Range, iOffset As Long
'Monatsnamen eintragen
wksUeber.Cells(Zeile, 1) = sMonat
'Zelle fett formatieren
wksUeber.Cells(Zeile, 1).Font.Bold = True
Zeile = Zeile + 1
'Prüfen, ob für Monat das Blatt "sblattname" vorhanden
If fncCheckSheet(wb:=ActiveWorkbook, varBlatt:=sBlattname) Then
With ActiveWorkbook.Worksheets(sBlattname)
Set ZelleStart = .Range(sStartZelle)
iOffset = 0
'Startzelle und folgende auf Inhalt prüfen
Do Until IsEmpty(ZelleStart.Offset(iOffset, 0))
'Wert(e) aus Zeile im Monatsblatt in Übersicht übertragen
wksUeber.Cells(Zeile, 1).Value = ZelleStart.Offset(iOffset, 0).Value
'Zeilenzähler erhöhen
iOffset = iOffset + 1
Zeile = Zeile + 1
Loop
End With
Else
MsgBox "Blatt für """ & sMonat & """ ist noch nicht angelegt oder " _
& "Blattname """ & sBlattname & """ ist ist nicht korrekt "
End If
'Zeilenzähler erhöhen für Leerzeile
Zeile = Zeile + 1
End Sub
Function fncCheckSheet(wb As Workbook, varBlatt) As Boolean
'Prüft ob Blatt in Arbeitsmappe vorhanden
Dim objSheet As Object
For Each objSheet In wb.Worksheets
If objSheet.Index = varBlatt Or LCase(objSheet.Name) = LCase(varBlatt) Then
fncCheckSheet = True
Exit For
End If
Next
End Function