AW: Funktioniert super. Noch eine Frage?
27.08.2017 16:11:21
Piet
Hallo Marco
es freut mich das meine Lösung auf Anhieb so gut klappt. Anbei der geanderte Code um Stationen als Text einzulesen.
Kleine Neuerung: - Oben gibt es eine Const Anweisung mit StationMax = 4 - Das ist die Anzahş der Stationen.
Den Wert kannst du beliebig erhöhen, dann schreibt das Makro in die naechsten Zeilen weiter. Kein Limit!
Ich schicke dir den ganzen Code zum auswechseln. Ist einfacher und vor allem Fehlerfrei.
Wenn der Trhead beendet ist bitte das Haeckchen nicht mehr aktivieren! - (sonst noch offen)
mfg Piet
Option Explicit '27.8.2017 Piet Herber Forum
'überarbeitet auf Station als Text
Const StationMax = 4 'Anzahl der Stationen (jetzt 4)
Dim Datum As Date, rfind As Range
Dim j As Long, n As Long, k As Integer
Dim Station As Variant, st As Integer
'Modul zum Fehlerhäufigkeit auflisten
Sub Fehlermeldungen_Auswerten()
Dim ASW As Worksheet, z As Long
Dim DSB As Worksheet, lz As Long
Dim FMD As Worksheet, dz As Long
Set ASW = Worksheets("ASW Liste")
Set DSB = Worksheets("Dashboard")
Set FMD = Worksheets("Fehlermeldungen")
'Datum aus Dashbord holen
Datum = DSB.Range("D3").Value
'LastCell in Fehlermeldungen ermitteln
lz = FMD.Cells(Rows.Count, 2).End(xlUp).Row
'Datum in Fehlermeldungen suchen
Set rfind = FMD.Columns(2).Find(What:=Datum, After:=Range("B3"), LookIn:= _
xlValues, LookAt:=xlWhole, SearchDirection:=xlNext, MatchCase:=False)
If rfind Is Nothing Then MsgBox Datum & " nicht gefunden": Exit Sub
Application.ScreenUpdating = False
'********** Kopieren Programm **********
'Datum Ende in Fehlermeldungen suchen
For j = 1 To lz
If rfind.Offset(j, 0) Datum Then Exit For
Next j
'alte Auswertung löschen
ASW.UsedRange.Offset(4, 0).Delete shift:=xlUp
'Datumsbereich in Auswertung kopieren + sortieren
rfind.Resize(j, 4).Copy ASW.Range("B4")
'Auswertung sortieren
Call ASW_Sortiere_Anlagen
'********** Auswertungs Programm **********
With ASW
'LastCell in Auswertung ermitteln
lz = .Cells(Rows.Count, 2).End(xlUp).Row
'Doppelte Fehler in Baugruppen löschen
For j = 4 To lz
'Anlagen Nummer + Baugruppe vegleichen
If .Cells(j + 1, 3) = .Cells(j, 3) Then
If .Cells(j + 1, 4) = .Cells(j, 4) Then
If .Cells(j + 1, 5) = .Cells(j, 5) Then _
.Cells(j + 1, 2).Resize(1, 4) = Empty
End If
End If
Next j
'Auswertung sortieren
Call ASW_Sortiere_Anlagen
'LastCell in Auswertung ermitteln
lz = .Cells(Rows.Count, 2).End(xlUp).Row
n = 1 'Häufigkeit Zähler auf 1 setzen
'Fehler Häufigkeit >1 ermitteln
For j = 4 To lz
'Anlagen Nummer vegleichen
If .Cells(j + 1, 3) = .Cells(j, 3) Then
'Fehlermeldung: vegleichen + addieren
If .Cells(j + 1, 5) = .Cells(j, 5) Then n = n + 1
'Fehlermeldung: Auswertung auflisten
If .Cells(j + 1, 5) .Cells(j, 5) Then
list: 'nur auflisten wenn n > 1
If n > 1 Then .Cells(j, 6) = n
n = 1
End If
Else: GoTo list
End If
Next j
End With
'Auswertung sortieren
Call ASW_Sortiere_Häufigkeit
'********** Dashboard Programm **********
'alte Dashboard Werte löschen + Überlauf
DSB.Range("D6:F25").ClearContents
'LastCell in Auswertung ermitteln Spalte F
lz = ASW.Cells(Rows.Count, 6).End(xlUp).Row
With ASW
'Schleife für Stationen 1-XX ausfüllen
For k = 1 To StationMax
dz = dz + 5 'Basis Zeile in Dashboard
Station = DSB.Cells(dz + 1, 2).Value
z = 0 'z in Auswertung suchen (Station)
'Schleife für 1. Zeile Station in ASW Liste finden
For st = 4 To lz
If .Cells(st, 3) = Station Then z = st: Exit For
Next st
If z = 0 Then MsgBox Station & " in ASW Liste nicht gefunden!!"
If z > 0 Then 'Station gefunden
'Schleife für Top Fünf auflisten
For j = 1 To 5
If .Cells(z, 3) Station Then Exit For
'Fehlermeldung + Häufigkeit eintragen
DSB.Cells(dz + j, 4) = .Cells(z, 5)
DSB.Cells(dz + j, 5) = .Cells(z, 6)
z = z + 1
Next j
'"Überlauf" Anzeige bei > 5 Einträgen
If j > 5 Then
'Schleife für next Station suchen
For j = 1 To 30
If .Cells(z, 3) Station Then Exit For
z = z + 1
Next j
'Überlauf nur wenn > 6 Einträge
If j > 1 Then DSB.Cells(dz + 5, 6) = j - 1 & " Überlauf"
End If
End If
Next k
End With
End Sub