AW: Komplizierte Schleife
17.06.2011 01:05:51
fcs
Hallo Klaus,
ich hab in meiner Lösung die Daten in ein temporäres Blatt übertragen, und dann ins Auswerteblatt.
Gruß
Franz
Sub Auswertung()
Dim wksTemp As Worksheet, wksKW As Worksheet, wksAusw As Worksheet
Dim Zeile1 As Long, Zeile As Long, Spalte As Long, iKW As Integer
Dim Zeile_T As Long, Spalte_T As Long, Tag As Long
Dim Zelle As Range
Dim sAktiv As String, sName As String
Dim Datum1 As Date, Datum2 As Date
'temporäres Tabellenblatt anlegen
Worksheets.Add
Set wksTemp = ActiveSheet
With wksTemp
.Columns(1).NumberFormat = "DD.MM.YYYY"
Zeile1 = 1
.Cells(Zeile1, 1) = "Datum"
End With
Zeile_T = 1
Application.ScreenUpdating = False
'Tabellenblätter der KW abarbeiten und Daten in temporäres Blatt schreiben
For iKW = 1 To 52
'prüfen, ob Blatt vorhanden
If fncCheckSheet(wb:=ActiveWorkbook, varBlatt:=CStr(iKW)) = True Then
Set wksKW = Worksheets(CStr(iKW))
For Zeile = 11 To 53 'Zeilen mit Namen in KW-Blättern
sName = wksKW.Cells(Zeile, 5).Value 'Name aus Spalte E
If sName "" Then
'Name in 1. Zeile im temporären Blatt suchen und Einfüge-Spalte bestimmen
Set Zelle = wksTemp.Rows(Zeile1).Find(What:=sName, LookIn:=xlValues, lookat:=xlWhole)
If Zelle Is Nothing Then
With wksTemp
Spalte_T = .Cells(Zeile1, .Columns.Count).End(xlToLeft).Column + 1
.Cells(Zeile1, Spalte_T).Value = sName
End With
Else
Spalte_T = Zelle.Column
End If
'Daten der 5 Tage übertragen
For Tag = 1 To 5 'Mo bis Fr
wksTemp.Cells(Zeile_T + Tag, 1).Value = wksKW.Cells(8, 5 + Tag).Value 'Datum
If wksKW.Cells(Zeile, 5 + Tag).Value "" Then
wksTemp.Cells(Zeile_T + Tag, Spalte_T).Value = wksKW.Cells(Zeile, 5 + Tag).Value ' _
Kürzel
End If
Next
End If
Next
'Zeilenzähler für temp. Blatt erhöhen
Zeile_T = Zeile_T + 5
End If
Next
Range("B2").Select
ActiveWindow.FreezePanes = True
With wksTemp
'temporäres Blatt formatieren
With .Range(Cells(Zeile1, 2), .Cells(Zeile1, .Columns.Count).End(xlToLeft))
.EntireColumn.HorizontalAlignment = xlHAlignCenter
.Orientation = 90
.EntireRow.RowHeight = 50
.EntireColumn.AutoFit
End With
Set wksAusw = Worksheets("Auswertung")
With wksAusw
Zeile = 11
'Altdaten löschen
If .Cells(.Rows.Count, 1).End(xlUp).Row > Zeile Then
.Range(.Rows(Zeile + 1), .Rows(.Cells(.Rows.Count, 1).End(xlUp).Row)).ClearContents
End If
End With
'Daten im temporären Blatt auswerten und nach Blatt Auswertung übertragen
For Spalte = 2 To .Cells(Zeile1, .Columns.Count).End(xlToLeft).Column
sName = .Cells(Zeile1, Spalte)
sAktiv = ""
For Zeile_T = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If .Cells(Zeile_T, Spalte).Value sAktiv Then
If sAktiv "" Then
Zeile = Zeile + 1
wksAusw.Cells(Zeile, 1) = sName
wksAusw.Cells(Zeile, 2) = Datum1
wksAusw.Cells(Zeile, 3) = Datum2
wksAusw.Cells(Zeile, 4) = sAktiv
End If
Datum1 = .Cells(Zeile_T, 1).Value
sAktiv = .Cells(Zeile_T, Spalte).Value
Else
End If
Datum2 = .Cells(Zeile_T, 1).Value
Next
Next
If sAktiv "" Then
Zeile = Zeile + 1
wksAusw.Cells(Zeile, 1) = sName
wksAusw.Cells(Zeile, 2) = Datum1
wksAusw.Cells(Zeile, 3) = Datum2
wksAusw.Cells(Zeile, 4) = sAktiv
End If
'Temporäres Blatt wieder löschen
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
Application.ScreenUpdating = True
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