AW: Filter-Makro gesucht
30.08.2015 15:38:00
Michael
Hallo Herbert,
ich habe zuallererst On Error bla auskommentiert, das nervt nur bei der Entwicklung, derweil VBA dann nicht in der fehlerhaften Code-Zeile stehenbleibt.
Mit dem Dictionary bin ich nicht groß vertraut: nach ein bißchen herumprobieren habe ich's aufgegeben.
Anbei ne reine Schleifenlösung, die zwar scheinbar viel zu viel arbeitet, aber bei den vorhandenen Testdaten mit ein paar ms auskommt: bei 530 wird es auch *ohne* "mit abgeschaltetem Alles" nicht "spürbar" brauchen.
Option Explicit
Sub AltlampenInZuweisung()
Dim dic As Object, arr, z As Long, iLastRow%, sFrage$
Dim t(0 To 2) As Single
Dim i&, j&
Const vonRD = 7, vonZuw = 9
t(0) = Timer
' On Error GoTo ende
' auskommentiert, sonst bleibt der Debugger nicht in der fehlerhaften
' Zeile stehen.
' Application.EnableEvents = False
' Application.Calculation = xlCalculationManual
iLastRow = Cells(Rows.Count, 2).End(xlUp).Row
'RaumDirekt!K$7:K$506
z = Sheets("RaumDirekt").Cells(Rows.Count, 11).End(xlUp).Row
arr = Sheets("RaumDirekt").Range("K1:R" & z)
' hier war übrigens die .Cells-Referenzierung verkehrt: 1004
' ab K *1*, das braucht man zwar nicht, aber die Umrechnerei mit Array/Sheet-Zeilen entfä _
llt
For i = 1 To z: arr(i, 3) = True: Next ' zum Überspringen unnötiger Schleifendurchgä _
nge
For i = vonRD To z
If arr(i, 3) Then
For j = i + 1 To z
If arr(j, 3) Then
If arr(i, 8) = arr(j, 8) Then arr(j, 3) = False
End If
Next
End If
Next
Range("B" & vonZuw & ":B" & iLastRow).ClearContents
j = 0
For i = vonRD To z
If arr(i, 3) Then
Range("B" & vonZuw + j).Value = arr(i, 1)
Range("C" & vonZuw + j).Value = arr(i, 8)
' nur zum Debuggen
j = j + 1
End If
Next
ende:
t(1) = Timer
MsgBox (t(1) - t(0)) * 1000 & " Millisekunden"
If Err > 0 Then
MsgBox "ERROR!"
Else
MsgBox "Fertig!"
End If
If Application.Calculation = xlCalculationManual Then
sFrage = MsgBox("Möchten Sie die autom. Berechnung einschalten?", vbYesNo, "Frage")
If sFrage = vbYes Then Application.Calculation = xlCalculationAutomatic
End If
Application.EnableEvents = True
End Sub
Schöne Grüße aus Nbg.,
Michael