AW: Ablaufdokumentation
15.01.2018 17:17:07
fcs
Hallo Sascha,
das Löschen der Altwerte zum Verlauf kann man in das Auswerte-Makro problemlos integerieren. Man muss "nur" die letzte benutzte Zelle noch ermitteln -andere benötigte Infos sind in den vorhandenen Makro-Anweisungen schon ermmitelt.
Für die automatische Aktualisierung kann man ein Ereignismakro erstellen, dass auf Eingaben in Spalte A reagiert. Siehe unten.
Alternativ könnte man mit OnTime arbeiten, um in regelmäßigen Zeitabständen die Auswertung zu starten - hier muss man dann aber besonders genaudarauf achten, dass im Auswerte-Makro die Objekte korrekt und vollständig referenziert sind.
z.B. muss
Set wksData = ActiveSheet
ersetzt werden durch
ThisworkBook.Worksheets("Tabelle1")
Denn die OnTime-Anweisungen werden auch ausgeführt, wenn andere Arbeitsmappen aktiv sind.
Zusätzlich muss man dafür sorgen, dass dass die OnTime-Anweisung vor dem Schliessen der Datei deaktiviert wird.
Ich hab beim Testen der Aktualisierung festgestellt, dass dass Färben eines fertigen Produkts noch nicht 100% funktioniert, wenn die Produkte einer Produktgruppe mehrfach komplettiert sind.
Hier hab ich das Makro nochmals angepasst.
Gruß
Franz
'Ereignismakro unter dem Codemodul des Tabellenblatts "Tabelle1"
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row > 1 And Target.Column = 1 Then
Call Auswertung
End If
End Sub
Sub Auswertung() 'Update 2018-01-15
Dim Zeile As Long, Spalte As Long, Zeile_L As Long
Dim k As Long
Dim arrProdGrp() As Long
Dim tmpSplit, j As Integer
Dim wksData As Worksheet
Dim zeiNr As Long
Dim varProdNr As Variant
Set wksData = ActiveSheet
With wksData
'Produkte der Produktgruppen in Spalte C einlesen
'letzte Zeile mit Inhalt in Spalte C
Zeile_L = .Cells(.Rows.Count, 3).End(xlUp).Row
If Zeile_L >= 2 Then 'es sind Daten vorhanden
'Datenarray für Produktgruppen dimensioneren
ReDim arrProdGrp(2 To Zeile_L, 1 To 3)
For Zeile = 2 To Zeile_L
'Prüfen, ob Zelle mit Produkten leer ist
If Trim(.Cells(Zeile, 3).Text) "" Then
'Einträge für Produkte am Komma trennen - erzeugt ein Daten-Array aus den _
Werten
tmpSplit = Split(.Cells(Zeile, 3).Text, ",")
'Werte aus dem Array in das Roduktgruppen-Array übertragen und dabei in _
Zahlen _
umwandeln - nicht nummerische Text werden dabei in 0 umgewandelt
For j = 0 To Application.WorksheetFunction.Min(2, UBound(tmpSplit))
arrProdGrp(Zeile, j + 1) = Val(tmpSplit(j))
Next
End If
Next Zeile
End If
'Zeile für Eintrag der Zeilennummer mit dem Produkt in Spalte A
'letzte Zeile mit Inhalt in Spalte B , Inhalt = Zeilennummer
zeiNr = .Cells(2, 2).End(xlDown).Row
'Produkt-Nummern in Spalte A von letzter Zeile nach Zeile 2 abarbeiten
Spalte = 3 'Spalte C - rechts davon werden übereinstimmende Produkt-Nrn eingetragen
'alte Daten und Zellfüllungen löschen
'letzte verwendete Spalte
With .UsedRange
k = .Column + .Columns.Count - 1
End With
With .Range(.Cells(2, Spalte + 1), .Cells(zeiNr, k))
.ClearContents
.Interior.ColorIndex = xlColorIndexNone
End With
For Zeile = .Cells(.Rows.Count, 1).End(xlUp).Row To 2 Step -1
varProdNr = .Cells(Zeile, 1).Value
'Produktnummer prüfen
Select Case varProdNr
Case 100, 111
'nachste Nummer überspringen
Zeile = Zeile - 1
Case Else
'Produktnummer in den Produktgruppen suchen
For k = LBound(arrProdGrp, 1) To UBound(arrProdGrp, 1)
For j = LBound(arrProdGrp, 2) To UBound(arrProdGrp, 2) '1 to 3
If varProdNr = arrProdGrp(k, j) Then
Spalte = Spalte + 1
.Cells(k, Spalte).Value = varProdNr
.Cells(zeiNr, Spalte).Value = Zeile
GoTo NextProdukt
End If
Next
Next
NextProdukt:
End Select
Next Zeile
'Komplette Produktgruppe markieren
Dim arrProd() As Long
Dim bolDrei() As Boolean, SpaMax As Long
'eingetragene Produkte ab Spalte D (4) in Array einlesen
ReDim arrProd(LBound(arrProdGrp, 1) To UBound(arrProdGrp, 1), 4 To Spalte)
For Zeile = LBound(arrProdGrp, 1) To UBound(arrProdGrp, 1)
For j = 4 To Spalte
arrProd(Zeile, j) = .Cells(Zeile, j)
Next
Next
'Produktgruppen abarbeiten
For Zeile = LBound(arrProdGrp, 1) To UBound(arrProdGrp, 1)
Do
ReDim bolDrei(1 To 3) 'Werte zurücksetzen
SpaMax = 4 'Wert zurücksetzen
'Produkte in Produktgruppen abarbeiten
For k = 1 To 3
'Produkt in Produktgruppe mit eingetragen Werten in Zeile vergleichen
For j = 4 To Spalte
If arrProdGrp(Zeile, k) = arrProd(Zeile, j) _
And arrProdGrp(Zeile, k) 0 Then
If SpaMax