Sub Aktualisieren()
Dim cRubrik As New Collection
Dim vBlatt As Variant
cRubrik.Add Worksheets("Reklamation")
cRubrik.Add Worksheets("PROZESSABWEICHUNG")
cRubrik.Add Worksheets("Lieferantenmanagement")
cRubrik.Add Worksheets("KVP")
cRubrik.Add Worksheets("Wissensmanagement")
cRubrik.Add Worksheets("AUDIT")
Dim i As Long
For i = 1 To cRubrik.Count
Rubrik_Aktualisieren cRubrik(i)
Next i
End Sub
Sub Rubrik_Aktualisieren(ByRef wsRubrik As Worksheet)
Dim rZBereich As Range
Dim rRBereich As Range
Dim lZZeile As Long
Dim lRZeile As Long
Dim lZSpalte As Long
Dim rFundzelle As Range
Dim lRCheckSpalte As Long
Dim vSpaltenindex
Dim vRubrik
Dim vZusammenfassung
With Worksheets("ZUSAMMENFASSUNG")
For Each rZBereich In .Range(.Range("A1"), .Cells(.Rows.Count, 1).End(xlUp))
If StrComp(rZBereich, wsRubrik.Name, vbTextCompare) = 0 And rZBereich.Font.ColorIndex = .Range("A1").Font.ColorIndex Then Exit For
Next rZBereich
End With
If rZBereich Is Nothing Then Exit Sub
With Worksheets("ZUSAMMENFASSUNG")
Set rZBereich = Range(rZBereich.End(xlDown), .Cells(rZBereich.End(xlDown).Row, .Columns.Count).End(xlToLeft))
End With
ReDim vSpaltenindex(1 To rZBereich.Columns.Count)
ReDim vZusammenfassung(1 To UBound(vSpaltenindex), 1 To 1)
With wsRubrik
Set rRBereich = .Range("A6")
Set rRBereich = Range(rRBereich, .Cells(.Cells(.Rows.Count, rRBereich.Column).End(xlUp).Row, .Cells(rRBereich.Row, .Columns.Count).End(xlToLeft).Column))
End With
vRubrik = rRBereich
For lZSpalte = 1 To UBound(vSpaltenindex)
Set rFundzelle = rRBereich.Rows(1).Find(rZBereich(lZSpalte), lookat:=xlWhole)
If Not rFundzelle Is Nothing Then
vSpaltenindex(lZSpalte) = rFundzelle.Column
End If
Next lZSpalte
Set rFundzelle = rRBereich.Rows(1).Find("Kontrolle Vorgang und Ablage vollständig, Archivierung", lookat:=xlPart)
If Not rFundzelle Is Nothing Then
lRCheckSpalte = rFundzelle.Column
For lRZeile = 2 To UBound(vRubrik, 1)
If vRubrik(lRZeile, lRCheckSpalte) = "pendent" Then
For lZSpalte = 1 To UBound(vZusammenfassung, 1)
If vSpaltenindex(lZSpalte) Then vZusammenfassung(lZSpalte, UBound(vZusammenfassung, 2)) = vRubrik(lRZeile, vSpaltenindex(lZSpalte))
Next lZSpalte
ReDim Preserve vZusammenfassung(1 To UBound(vZusammenfassung, 1), 1 To UBound(vZusammenfassung, 2) + 1)
End If
Next lRZeile
End If
With Worksheets("ZUSAMMENFASSUNG")
If rZBereich.CurrentRegion.Rows.Count > UBound(vZusammenfassung, 2) Then
Range(.Cells(rZBereich.Row + UBound(vZusammenfassung, 2), 1), .Cells(rZBereich.Row + rZBereich.CurrentRegion.Rows.Count - 1, 1)).EntireRow.Delete
ElseIf rZBereich.CurrentRegion.Rows.Count < UBound(vZusammenfassung, 2) Then
Range(.Cells(rZBereich.Row + rZBereich.CurrentRegion.Rows.Count, 2), .Cells(rZBereich.Row + UBound(vZusammenfassung, 2) - 1, 2)).EntireRow.Insert CopyOrigin:=xlFormatFromRightOrBelow
End If
rZBereich.Offset(1).Resize(UBound(vZusammenfassung, 2), UBound(vZusammenfassung, 1)) = Application.WorksheetFunction.Transpose(vZusammenfassung)
End With
End Sub
Sub Zufall()
Application.EnableEvents = False
Dim cRubrik As New Collection
Dim rRBereich As Range
Dim lRZeile As Long
Dim rFundzelle As Range
Dim lRCheckSpalte As Long
Randomize Timer
cRubrik.Add Worksheets("Reklamation")
cRubrik.Add Worksheets("PROZESSABWEICHUNG")
cRubrik.Add Worksheets("Lieferantenmanagement")
cRubrik.Add Worksheets("KVP")
cRubrik.Add Worksheets("Wissensmanagement")
cRubrik.Add Worksheets("AUDIT")
Dim i As Long
For i = 1 To cRubrik.Count
With cRubrik(i)
.Activate
Set rRBereich = .Range("A6")
Set rRBereich = Range(rRBereich, .Cells(.Cells(.Rows.Count, rRBereich.Column).End(xlUp).Row, .Cells(rRBereich.Row, .Columns.Count).End(xlToLeft).Column))
End With
Set rFundzelle = rRBereich.Rows(1).Find("Kontrolle Vorgang und Ablage vollständig, Archivierung", lookat:=xlPart)
If rFundzelle Is Nothing Then
cRubrik(i).Activate
MsgBox "Achtung! " & vbCr & "Kontrollspalte im " & vbCr & _
"Blatt """ & cRubrik(i).Name & """ nicht gefunden. " & vbCr & "Kein Eintrag in dieser Rubrik. "
Else
lRCheckSpalte = rFundzelle.Column
For lRZeile = 2 To rRBereich.Rows.Count
If Rnd > 0.2 Then
rRBereich(lRZeile, lRCheckSpalte) = "pendent"
Else
rRBereich(lRZeile, lRCheckSpalte) = "erledigt"
End If
Next lRZeile
End If
Next i
Application.EnableEvents = True
End Sub