AW: Maximalwert aus liste Mit unterbrechnung
20.09.2014 10:06:34
Mullit
Hallo,
die Events mussten noch an anderer Stelle ausgeschaltet werden, Du kannst die Formel jetzt an beliebiger Stelle einfügen, die Arrayformeln werden immer auf Tabellenhöhe eingefügt und zwar nur in den Ergebniszellen.
Über die öffentlichen Konstanten kannst Du jetzt Deine Ausgangstabelle bestimmen.
Die UDF brauchst Du nur in eine Zelle einfügen und nicht runterziehen.
' **********************************************************************
' Modul: Tabelle1 Typ: Klassenmodul des Tabellenblattes
' **********************************************************************
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Static sobjRange As Range
With Target
If .Count = 1 Then
If Left$(String:=CStr(.Formula), _
Length:=Len("=fncNoDuplicates")) = "=fncNoDuplicates" Then
If Target.Row = START_ROW Then
Set sobjRange = Target
Else
Set sobjRange = Cells(START_ROW, Target.Column)
End If
End If
End If
If sobjRange Is Nothing Then _
Set sobjRange = Cells(START_ROW, COLUMN_NODUPLICATES)
If Not Intersect(Cells(START_ROW, COLUMN_ALLTOWN).Resize( _
Cells(Rows.Count, 1).End(xlUp).Row, COLUMN_ALLTOWN), Target) Is Nothing Or _
Not Intersect(Cells(START_ROW, START_COLUMN).Resize( _
Cells(Rows.Count, 1).End(xlUp).Row, START_COLUMN), Target) Is Nothing And _
Cells(.Row, .Column + 1).Text <> vbNullString Then
Application.EnableEvents = False
sobjRange.Formula = fncNoDuplicates(oprobjRange:=Cells( _
START_ROW, COLUMN_ALLTOWN).Resize(Cells(Rows.Count, 1).End(xlUp).Row, COLUMN_ALLTOWN), _
oprobjCell:=sobjRange)
Application.EnableEvents = True
End If
End With
End Sub
' **********************************************************************
' Modul: Typ: Standardmodul
' **********************************************************************
Option Explicit
Private Declare Function SetTimer Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
Public Const START_ROW As Long = 3 'Tabelle 1.Zeile
Public Const COLUMN_NODUPLICATES As Long = 5 'Spalte versch. Städte
Public Const COLUMN_ALLTOWN As Long = 2 'Spalte alle Städte
Public Const START_COLUMN As Long = 1 'Tabelle 1.Spalte
Private lobjCell As Range
Private llngRow As Long
Private llngLastRow As Long
Public Function fncNoDuplicates(Optional oprobjRange As Range, _
Optional oprobjCell As Range) As String
Dim lngIndex As Long
Dim objRange As Range
With Application.Caller
If Not oprobjRange Is Nothing Then
With oprobjRange
llngLastRow = Cells(.Rows.Count, .Column).Row
End With
Else
On Error Resume Next
lngIndex = .Row
If Err.Number = 0 Then _
llngLastRow = Cells(Rows.Count, START_COLUMN).End(xlUp).Row
On Error GoTo 0
End If
If Not lobjCell Is Nothing Then
With lobjCell
lngIndex = .Row
Set objRange = Cells(.Row + 1, START_COLUMN)
End With
ElseIf oprobjCell Is Nothing Then
If .Row <> START_ROW Then
lngIndex = START_ROW - 1
Set objRange = Cells(START_ROW, START_COLUMN)
Else
lngIndex = .Row - 1
Set objRange = Cells(.Row, START_COLUMN)
End If
Else
With oprobjRange.Cells(1, 1)
lngIndex = .Row - 1
Set objRange = Cells(.Row, START_COLUMN)
End With
End If
Do
lngIndex = lngIndex + 1
Loop While Cells(lngIndex, START_COLUMN) = objRange And Cells(lngIndex, COLUMN_ALLTOWN) <> vbNullString
If Not lobjCell Is Nothing Then
With lobjCell
Set lobjCell = Cells(.Row + 1, .Column)
End With
ElseIf oprobjCell Is Nothing Then
If .Row <> START_ROW Then
Set lobjCell = Cells(START_ROW, .Column)
Else
Set lobjCell = Application.Caller
End If
Else
Set lobjCell = oprobjCell
End If
End With
llngRow = lngIndex - 1
Set objRange = Nothing
Call prcStartTimer
End Function
Private Sub prcStartTimer()
SetTimer Application.hwnd, 0&, 1&, AddressOf TimerProc
End Sub
Private Sub prcStopTimer()
KillTimer Application.hwnd, 0&
End Sub
Private Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long)
On Error Resume Next
Call prcStopTimer
Call prcFormula
End Sub
Private Sub prcFormula()
Dim lngRow As Long
With Application
If .EnableEvents Then _
.EnableEvents = False
End With
With lobjCell
.FormulaArray = "=IF(AND(A" & .Row & "<>"""",A" & .Row & "<>A" & .Row - 1 & "),SUM(1/COUNTIF(B" & .Row & _
":B" & llngRow & ",B" & .Row & ":B" & llngRow & ")),"""")"
If .Row < llngLastRow Then
On Error GoTo Sub_Exit
lngRow = Cells(.Row + 1, START_COLUMN).Resize(llngLastRow, START_COLUMN).Find( _
What:=Cells(.Row, 1) + 1, LookIn:=xlValues, LookAt:=xlWhole).Row
On Error GoTo 0
Set lobjCell = Cells(lngRow - 1, .Column)
Cells(lngRow, .Column).Formula = fncNoDuplicates()
Else
Sub_Exit:
Set lobjCell = Nothing
llngRow = 0
llngLastRow = 0
Application.EnableEvents = True
End If
End With
End Sub
VBA/HTML - CodeConverter für Office-Foren
AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel
Code erstellt und getestet in Office 14
Gruß,