CountIf und SpecialCells ...
03.07.2022 11:06:38
Kalle
das Wetter ist schön, aber ein Excel Problem lässt mich nicht raus. Im Rahmen meines Projekts strebe ich eine beschleunigte Prüfung gewisser Bedingungen an, die über Change-Ereignisse erfasst werden. Ziel: CountIf nur über sichtbare Spalten laufen lassen und entpsrechende Berechnungen/Aktualisierungen beschleunigen. Konkret: gesetzte "x" und gesetzte "p" bestimmen und weiterverwerten.
Ich habe bereits für meine Zwecke eine 100% lauffähige Variante erstellt (auskommentiert); der Versuch, das ganze über Areas und SpecialCells zu verschlanken wirft zwar keine Fehler aus, rechnet aber nur Unsinn (keine korrekten Summen, egal ob "x" oder die Zeiten) ... und ich habe keine Ahnung, wo der Denkfehler liegt. In der Demo einfach mit "x" und "p" etwas herumprobieren. Die Zeiten für die Einzeltestdauer zieht er sich aus Zeile 2. Hier der kommentierte Code für beide Varianten und die Demo https://www.herber.de/bbs/user/153948.xlsm :
Danke für Eure Hilfe ... bin ja mal gespannt, woran es liegt
VG Kalle
Private Sub Worksheet_Change(ByVal Target As Range)
Dim DValue, UValue, PValue As String
DValue = Format(Date, "dd.mm.yy")
UValue = Left(Environ$("USERNAME"), 2)
Dim i, tt, td, count_p, count_x, slr As Long
slr = Sheets("TESTPLANUNG").Cells(Rows.Count, 1).End(xlUp).Row
If Not Intersect(Range("M6:AF" & slr), Target) Is Nothing Then
Cells(1, 33) = " letzte Planung: " & UCase(Environ$("USERNAME")) & ", " & DValue
If Target.Count = 1 Then
Application.EnableEvents = False
Application.ScreenUpdating = False
'funktioniert so wie es soll, aber hoher Prüfaufwand
Target.Value = LCase(Target.Value)
If Target.Value = "p" Then
Target.Value = Target.Value & UValue 'jeder Testleiter bekommt seine Initialien an das "p"
End If
' 'Vorgang 1: bestimme alle x und p? in der Target-Zeile über alle Spalten mit Tests
' With ActiveSheet
' count_x = Application.CountIf(.Range(.Cells(Target.Row, 13), .Cells(Target.Row, 32)), "x")
' count_p = Application.CountIf(.Range(.Cells(Target.Row, 13), .Cells(Target.Row, 32)), "p?")
' Cells(Target.Row, 33).Value = count_x 'aktualisiere offene Tests "x" in Spalte AH
' If count_p = 0 Then
' Cells(Target.Row, 34).ClearContents 'leere Zelle, wenn kein Test geplant ist
' End If
' 'Vorgang 2: bei Veränderung wird die Gesamnttestdauer aus Reihe 2 in Spalte AG über alle sichtbaren Spalten mit "p?" gebildet
' For i = 13 To 32
' If Cells(Target.Row, i).Value Like "p?" Then
' tt = tt + Cells(2, i).Value
' Cells(Target.Row, 34).Value = tt / (24 * 60) 'Umrechnung in verständliches Zeitmaß
' End If
' Next i
' End With
' 'Ende von funktioniert so wie es soll, aber hoher Prüfaufwand
'neuer Vorschlag, aber rechnet nicht richtig ...
Dim plan_data_row As Range
Dim cell_check As Range
'Vorgang 1: bestimme alle x und p? in der Target-Zeile in allen sichtbaren Spalten
Set plan_data_row = Range(Cells(Target.Row, 13), Cells(Target.Row, 32)).SpecialCells(xlCellTypeVisible)
For Each cell_check In plan_data_row.Areas
count_x = Application.WorksheetFunction.CountIf(cell_check, "x")
count_p = Application.WorksheetFunction.CountIf(cell_check, "p?")
Next cell_check
Cells(Target.Row, 33).Value = count_x 'aktualisiere offene Tests "x" in Spalte AH
If count_p = 0 Then
Cells(Target.Row, 34).ClearContents 'leere Zelle, wenn kein Test geplant ist
End If
'Vorgang 2: bei Veränderung wird die Gesamnttestdauer aus Reihe 2 in Spalte AH über alle sichtbaren Spalten mit "p?" gebildet
For Each cell_check In plan_data_row.Areas
If Target.Value Like "p?" Then
tt = tt + Cells(2, Target.Column).Value
Cells(Target.Row, 34).Value = tt / (24 * 60) 'Umrechnung in verständliches Zeitmaß
End If
Next cell_check
End If 'target count
End If 'intersect
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub