AW: Excel ist eine Tabellenkalkulation, keine ...
11.07.2013 11:33:00
fcs
Hallo Pascal,
ein paar Sachen kann man schon noch machen, aber Masse ist halt Masse.
23 Suchbegriffe mal 100000 Datenzeilen sind halt 2,3 Mio Schleifendurchläufe.
In deinem Makro sind folgende Optimierungen möglich:
1. Die Begriffe in Spalte O werden in jedem Schleifendurchlauf auf 11 Zeichen abgeschnitten.
Das sollte man nur einmal machen und die Ergebnisse in einem separaten Array ablegen.
Dabei sollte dann der Text bis zum 1. Punkt ausgelesen werden (Das scheint ja der wichtige Vergleichstext zu sein)
2. Der in 1. ermittelte String kann dann per = mit den Kriterien verglichen werden.
Das ist schneller als Instr-Wert zu vergleichen und du bekommst keine Mehrfachausgabe einzelner Zeilen für Kriterien, denn "Drucker2" als Kriterium liefert auch die Zeilen mit "Drucker21" als Ergebniszeilen.
3. Du muss nicht in jedem Schleifendurchlauf die Daten im Blatt "SM7_Tickets" eintragen.
Es reicht wenn du es wie beim Auswertungsblatt einmal am Ende machts.
Das dürfte auch bei dir der Zeitfaktor sein, denn Datenarrays sind schon extrem schnell im Vergleich zu jeder Zelloperation in einem Tabellenblatt.
Ich hab dein Makro mal in diese Richtung modifiziert.
Ansonsten wäre noch ein Ansatz im Blatt Probleme in einer weiteren Spalte P den Text aus Spalte O bis zum 1. Punkt einzutragen. Danach kannst du dann mit dem Autofilter oder auch Pivot-Tabellenbericht arbeiten um Auswertungen zu machen.
Gruß
Franz
Public Sub Auswertung()
On Error Resume Next
Dim arrIn As Variant
Dim ArrKriterien As Variant
Dim arrOut As Variant
Dim L As Long
Dim lngCount As Long
Dim lngIndex As Long
Dim CI_Text_11() As String
arrIn = Sheets("Probleme").Range("A1").CurrentRegion
ArrKriterien = Sheets("Such-Kriterien").Range("A3:A26") 'Anpassen
ReDim arrOut(1 To UBound(arrIn), 1 To UBound(arrIn, 2) + 1)
ReDim CI_Text_11(1 To UBound(arrIn))
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
'Altdaten löschen
With Worksheets("Auswertungen")
L = .Cells(.Rows.Count, 1).End(xlUp).Row
If L > 2 Then
.Range(.Rows(3), .Rows(L)).ClearContents
End If
End With
With Worksheets("SM7_Tickets")
L = .Cells(.Rows.Count, 1).End(xlUp).Row
If L > 2 Then
.Range(.Cells(3, 1), .Cells(L, 6)).ClearContents
End If
End With
'liest aus der Spalte O (CI) die Zeichen bis zum 1. Punkt aus
For lngCount = 1 To UBound(arrIn)
L = InStr(1, arrIn(lngCount, 15), ".")
If L = 0 Then
CI_Text_11(lngCount) = arrIn(lngCount, 15)
Else
CI_Text_11(lngCount) = Left(arrIn(lngCount, 15), L - 1)
End If
Next
For L = LBound(ArrKriterien) To UBound(ArrKriterien)
For lngCount = 1 To UBound(arrIn)
If InStr(1, arrIn(lngCount, 6), ArrKriterien(L, 1)) Or _
CI_Text_11(lngCount) = ArrKriterien(L, 1) Then
lngIndex = lngIndex + 1
arrOut(lngIndex, 1) = ArrKriterien(L, 1)
arrOut(lngIndex, 2) = arrIn(lngCount, 1)
arrOut(lngIndex, 3) = arrIn(lngCount, 2)
arrOut(lngIndex, 4) = arrIn(lngCount, 3)
arrOut(lngIndex, 5) = arrIn(lngCount, 4)
arrOut(lngIndex, 6) = arrIn(lngCount, 5)
arrOut(lngIndex, 7) = arrIn(lngCount, 6)
arrOut(lngIndex, 8) = arrIn(lngCount, 7)
arrOut(lngIndex, 9) = arrIn(lngCount, 8)
arrOut(lngIndex, 10) = arrIn(lngCount, 9)
arrOut(lngIndex, 11) = arrIn(lngCount, 10)
arrOut(lngIndex, 12) = arrIn(lngCount, 11)
arrOut(lngIndex, 13) = arrIn(lngCount, 12)
arrOut(lngIndex, 14) = arrIn(lngCount, 13)
arrOut(lngIndex, 15) = arrIn(lngCount, 14)
arrOut(lngIndex, 16) = arrIn(lngCount, 15)
If lngIndex = UBound(arrOut) Then
MsgBox "Outarray ist voll"
End If
End If
Next
Next
Sheets("Auswertungen").Range("A3:P" & lngIndex + 3) = arrOut
Sheets("SM7_Tickets").Range("A3:B" & lngIndex + 3) = arrOut
With Worksheets("SM7_Tickets")
L = .Cells(.Rows.Count, 1).End(xlUp).Row
If L > 2 Then
.Range(.Cells(3, 4), .Cells(L, 4)).FormulaR1C1 = "=IF(RC[-3]=R[-1]C[-3],"""",RC[-3])"
.Range(.Cells(3, 4), .Cells(L, 4)).FormulaR1C1 = "=RC[-4])"
End If
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub