AW: zeichenfolge suchen und addieren
16.03.2015 16:48:15
fcs
Hallo Björn,
ich hab mal einen anderen Ansatz probiert. Entscheidend für die Auswertung ist ja die nicht zu berücksichtigenden Textteile der Einträge in Spalte A der Testdaten in der Auswertung zu eliminieren.
Wichtig für meinen Ansatz ist, dass die Daten im Vergleichs-Array fr() aufsteigend sortiert sind.
Die Auswertung erfolgt dann komplett in Datenarrays. das ist normalweise sehr flott in der Makroausführung.
Schau mal ob es passt.
Gruß
Franz
Sub auswertung_neu()
Dim fr(5) As String, n
Dim Zeile_L As Long
Dim arrData As Variant, lngK As Long
Dim arrErgebnis As Variant, lngE As Long
Dim wksData As Worksheet
Dim wksNalysis As Worksheet
Dim varVergleich(1 To 2)
'Vergleichsarray
fr(0) = "A01"
fr(1) = "A02"
fr(2) = "A02.1"
fr(3) = "A02.2"
fr(4) = "A02.3"
fr(5) = "A02.4"
Set wksData = ActiveWorkbook.Sheets("test")
Set wksAnalysis = ActiveWorkbook.Sheets("Analysis")
With wksData
'.Activate
'Testdaten in array einlesen - 3 Spalte wird zum testen benötigt
arrData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 2))
End With 'wksData
'In Dritter Spalte des Array alle Inhalte auf False setzen
For lngK = LBound(arrData, 1) To UBound(arrData, 1)
arrData(lngK, 3) = False
Next lngK
'In Spalte A die nicht auszuwertenden Texte am Ende entfernen _
dazu wird das aufsteigend sortierte Array vom Ende zum Anfang abgearbeitet
For n = UBound(fr) To LBound(fr) Step -1
For lngK = LBound(arrData, 1) To UBound(arrData, 1)
'prüfen, ob Wert in Spalte 1 noch nicht zugeschnitten wurde
If arrData(lngK, 3) = False Then
If Left(arrData(lngK, 1), Len(fr(n))) = fr(n) Then
arrData(lngK, 1) = fr(n)
arrData(lngK, 3) = True
End If
End If
Next lngK
Next n
'Ergebnisarray anlegen
ReDim arrErgebnis(LBound(fr) To UBound(fr), 1 To 4)
'Testwerte aus B1 und C1 in Variablen einlesen, beschleunigt die weitere Makro-Ausführung
varVergleich(1) = wksAnalysis.Cells(1, 2)
varVergleich(2) = wksAnalysis.Cells(1, 3)
'Ergebnisarray berechnen
For lngE = LBound(arrErgebnis) To UBound(arrErgebnis)
arrErgebnis(lngE, 4) = fr(lngE)
arrErgebnis(lngE, 3) = 0
arrErgebnis(lngE, 2) = 0
arrErgebnis(lngE, 1) = 0
For lngK = LBound(arrData, 1) To UBound(arrData, 1)
'prüfen, ob Vergleichswert übereinstimmt
If arrData(lngK, 1) = arrErgebnis(lngE, 4) Then
'prüfen, ob Testwert übereinstimmt
Select Case arrData(lngK, 2)
Case varVergleich(1)
arrErgebnis(lngE, 2) = arrErgebnis(lngE, 2) + 1
Case varVergleich(2)
arrErgebnis(lngE, 3) = arrErgebnis(lngE, 3) + 1
Case Else
'do nothing
End Select
End If
Next lngK
'UND-Übereinstimmungen prüfen bei Testwerten
If arrErgebnis(lngE, 2) >= 1 And arrErgebnis(lngE, 3) >= 1 Then
arrErgebnis(lngE, 1) = 1
End If
Next lngE
'Ergebnisse in Blatt Analysis eintragen
With wksAnalysis
Zeile_L = .Cells(.Rows.Count, 4).End(xlUp).Row
If Zeile_L >= 2 Then
.Range(.Cells(2, 1), .Cells(Zeile_L, 4)).ClearContents
End If
.Cells(2, 1).Resize(UBound(arrErgebnis) - LBound(arrErgebnis) + 1, 4).Value = arrErgebnis
End With
Erase arrErgebnis, arrData
End Sub