AW: VBA - anstatt suche in Zelle, Array auslesen
23.09.2017 22:24:23
onur
Option Explicit '29.8.2017 'überarbeitet 13.9. Piet Herber Forum
'überarbeitet: 29/30.8.
'Datum an Fehlertext angehangen
Dim Bereich As String, rFind As Object
Dim Station As String, dsbcol As Integer
Dim DBEdr As String, Material As Variant
Dim lzAsw As Long, lzDsb As Long, z As Long
Dim DTxt As String, Jahr As Variant
Dim found As Boolean
Dim v, xx
'Modul zum Dashboard ausfüllen
Sub Dashboard_auflisten()
Dim j As Integer, k As Integer, ü As Integer
Dim Cache As Worksheet, DSB As Worksheet
Set Cache = Worksheets("Cache")
Set DSB = Worksheets("Dashboard")
'********** Dashboard Programm **********
'alte Dashboard Werte löschen + Überlauf
DSB.Range("H11:I40, V11:W40, AJ11:AK40, H49:I117, V49:W117, AJ49:AK117, H126:I170, V126:W170, _
AJ126:AK170").ClearContents
Cache.Range("G5:H500") = Empty '** zum testen gelöscht
'"Überlauf" Innenfarbe löschen
'** Spalten J-S sind ausgeblendet !!
DSB.Columns("J:T").Interior.ColorIndex = xlNone
DSB.Columns("X:AH").Interior.ColorIndex = xlNone
DSB.Columns("AL:AV").Interior.ColorIndex = xlNone
Application.ScreenUpdating = True
'Dashboard End-Adresse feststellen (für Suchlauf)
DBEdr = DSB.Cells.SpecialCells(xlCellTypeLastCell).Address
lzDsb = DSB.Range(DBEdr).Row + 1 'LastZell in Dashboard
With Cache
'LastCell in Auswertung ermitteln Spalte F
lzAsw = .Cells(Rows.Count, 6).End(xlUp).Row
Jahr = Year(DSB.Range("E7")) 'akt. Jahr
'Schleife für alle Stationen aus Cache
'** For k = 4 To lzAsw
For k = 5 To lzAsw
z = 0 'Station Zeile löschen
Station = .Cells(k, 3).Value
Material = .Cells(k, 4).Value
v = Split(Cells(9, 7), ";")
found = False
For xx = 0 To UBound(v)
If Val(v(xx)) = Material Then
found = True
Exit For
End If
Next xx
If Not found Then
MsgBox "Suchlauf Fehler" & vbLf & Station & " " & Material & " - nicht gefunden" _
Else
'Suche die Material Nummer in Dashboard Spalte "G9" - XXX
'Set rFind = DSB.Range("G9", DBEdr).Find(What:=Material, After:=Range("G9"), _
LookIn:=xlValues, _
'LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False)
'If rFind Is Nothing Then MsgBox "Suchlauf Fehler" & vbLf & Station & " " & _
Material & " - nicht gefunden"
'If Not rFind Is Nothing Then
'Bereichs Name zum Prüfen laden
Bereich = DSB.Cells(9, 4).Value
dsbcol = 7 + 1 'Material Spalte
'wenn vorhanden suche Station Name in diesem Bereich
'** Aussprung wenn next Bereich vorkommt!!
For j = 9 + 1 To lzDsb
If Left(DSB.Cells(j, "D"), 7) = "Bereich" Then Exit For
If DSB.Cells(j, "D") = Station Or DSB.Cells(j, "E") = Station Then z = j: _
Exit For
Next j
If z = 0 Then MsgBox Bereich & ": " & Station & " nicht gefunden"
'wenn vorhanden Top 3 Fehler auflisten
If z > 0 And DSB.Cells(j, dsbcol) = Empty Then
'Schleife für Top 3 Fehler auflisten
'Aussprung bei Station oder Material
For j = 1 To 3
'Datum Text laden und verkürzen (ohne Jahr + sec.)
With .Cells(k, 2)
If IsDate(.Value) Then
DTxt = Format(CDate(.Value), "DD.MM. hh.mm")
Else
DTxt = .Text
End If
End With
If .Cells(k, 3) Station Then Exit For 'Station
If .Cells(k, 4) Material Then Exit For 'Material
DSB.Cells(z, dsbcol + 0) = .Cells(k, 6) 'Häufigkeit
DSB.Cells(z, dsbcol + 1) = .Cells(k, 5) 'Old, ohne Zeit
.Cells(k, 7).Value = " Ok" 'ist notiert
z = z + 1: k = k + 1 'next Zeile
Next j
'** Offset dsbcol + 12 weil Spalten J-S ausgeblendet sind !!
If .Cells(k, 3) = Station And .Cells(k, 4) = Material Then
DSB.Cells(z - 1, dsbcol + 2).Interior.ColorIndex = 3 'J,X,AL
DSB.Cells(z - 1, dsbcol + 12).Interior.ColorIndex = 3 'T,AH,AV
'Schleife für Überflüssige Fehler überspringen
For j = 1 To 20
.Cells(k, 8).Value = " Übl" 'ist notiert
k = k + 1 'next Zeile
If .Cells(k, 6) = Empty Then Exit For 'Häufigkeit
If .Cells(k, 3) Station Then Exit For 'Station
If .Cells(k, 4) Material Then Exit For 'Material
Next j
End If
k = k - 1 'Korrektur -1 für next Startadresse
ElseIf z > 0 Then
MsgBox " Zelle bereits belegt: " & DSB.Cells(j, dsbcol).Address
End If
End If
Next k
'LastCell für "Überlauf" ermitteln Spalte G
lzAsw = .Cells(Rows.Count, 7).End(xlUp).Row
For k = 5 To lzAsw
If .Cells(k, 7) = Empty Then ü = ü + 1
If .Cells(k, 7) & .Cells(k, 1) = Empty Then
.Cells(k, 1) = "Überlauf"
.Cells(k, 1).Font.ColorIndex = 3
End If
Next k
End With
'Überlauf in Dahsboard notieren
'If ü = 1 Then DSB.Range("I8") = ü & " Überlauf"
'If ü > 1 Then DSB.Range("I8") = ü & " Überläufe"
Application.ScreenUpdating = True
'If ü = 1 Then MsgBox ü & " Überlauf"
'If ü > 1 Then MsgBox ü & " Überläufe"
End Sub
