Verbesserung Code

Public Sub x_loeschen() Dim i As Integer Dim s As Integer Dim z As Integer For i = 15 To 136 For z = 19 To 509 For s = 6 To 100 If Sheets(3).Cells(i, 3).Value = Sheets(2).Cells(z, 2).Value And Sheets(3).Cells(i, 6).Value = _ Sheets(2).Cells(13, s).Value Then Sheets(2).Cells(z + 3, s).Value = "" End If Next s Next z Next i End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Public Sub x_loeschen() Dim i As Integer Dim s As Integer Dim z As Integer Application.ScreenUpdating = False For i = 15 To 136 For z = 19 To 509 For s = 6 To 100 If Sheets(3).Cells(i, 3).Value = Sheets(2).Cells(z, 2).Value And Sheets(3).Cells(i, 6).Value = _ _ Sheets(2).Cells(13, s).Value Then Sheets(2).Cells(z + 3, s).Value = "" End If Next s Next z Next i Application.ScreenUpdating = True End Sub

Option Explicit Public Sub x_loeschen() Dim i As Integer Dim s As Integer Dim z As Integer With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False End With For i = 15 To 136 For z = 19 To 509 For s = 6 To 100 If Sheets(3).Cells(i, 3).Value = Sheets(2).Cells(z, 2).Value And Sheets(3).Cells(i, 6). _ Value = Sheets(2).Cells(13, s).Value Then Sheets(2).Cells(z + 3, s).ClearContents End If Next s Next z Next i With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True End With End Sub

Sub x_Loeschen() 'z1=Bz z2=s13 q1=Ci q2=Fi Const zbZlVsatz As Long = 3, adQVBer1$ = "C15:C136", adQVBer2$ = "F15:F136", _ adZVBer1$ = "B19:B509", adZVBer2$ = "F13:CV13" Dim ix As Long, lb As Long, qvb, qvBer, qvBer1, qvBer2 As Variant, _ zfb1 As Range, zfb2 As Range, zvBer1 As Range, zvBer2 As Range, _ qSh As Worksheet, zSh As Worksheet Set qSh = Worksheets(3): Set zSh = Worksheets(2) Set zvBer1 = zSh.Range(adZVBer1): Set zvBer2 = zSh.Range(adZVBer2) With WorksheetFunction qvBer1 = .Transpose(qSh.Range(adQVBer1)) qvBer2 = .Transpose(qSh.Range(adQVBer2)) End With lb = LBound(qvBer2): ReDim qvBer(UBound(qvBer2) - lb) For Each qvb In qvBer1 qvBer(ix) = Array(qvb, qvBer2(ix + lb)): ix = ix + 1 Next qvb For Each qvb In qvBer If IsEmpty(qvb(0)) Or IsEmpty(qvb(1)) Then GoTo nx Set zfb1 = zvBer1.Find(qvb(0), zvBer1.Cells(1).Offset(-1, 0), _ xlValues, xlWhole, xlTopToBottom, xlNext) Set zfb2 = zvBer2.Find(qvb(1), zvBer2.Cells(1).Offset(0, -1), _ xlValues, xlWhole, xlLeftToRight, xlNext) While Not (zfb1 Is Nothing Or zfb2 Is Nothing) ' zSh.Cells(zfb1.Row + zbZlVsatz, zfb2.Column).ClearContents zSh.Cells(zfb1.Row + zbZlVsatz, zfb2.Column).Interior.Color = vbRed Set zfb1 = zvBer1.FindNext: Set zfb2 = zvBer2.FindNext Wend nx: Next qvb Set qSh = Nothing: Set zfb1 = Nothing: Set zvBer1 = Nothing Set zSh = Nothing: Set zfb2 = Nothing: Set zvBer2 = Nothing End Sub

…Mia & all: ;-)

Sub x_LoeschenL()
Const zbZlVsatz As Long = 3, adQVBer1$ = "C15:C136", adQVBer2$ = "F15:F136", _
adZVBer1$ = "B19:B509", adZVBer2$ = "F13:CV13"
Dim ix As Long, lb As Long, qvb, qvBer, qvBer1, qvBer2 As Variant, _
zfb1 As Range, zfb2 As Range, zvBer1 As Range, zvBer2 As Range, _
qSh As Worksheet, zSh As Worksheet
Set qSh = Worksheets(3): Set zSh = Worksheets(2)
Set zvBer1 = zSh.Range(adZVBer1): Set zvBer2 = zSh.Range(adZVBer2)
With WorksheetFunction
qvBer1 = .Transpose(qSh.Range(adQVBer1))
qvBer2 = .Transpose(qSh.Range(adQVBer2))
End With
lb = LBound(qvBer2): ReDim qvBer(UBound(qvBer2) - lb)
For Each qvb In qvBer1
qvBer(ix) = Array(qvb, qvBer2(ix + lb)): ix = ix + 1
Next qvb
For Each qvb In qvBer
If IsEmpty(qvb(0)) Or IsEmpty(qvb(1)) Then GoTo nx
Set zfb1 = zvBer1.Find(qvb(0), zvBer1.Cells(zvBer1.Count), _
xlValues, xlWhole, xlTopToBottom, xlNext)
Set zfb2 = zvBer2.Find(qvb(1), zvBer2.Cells(zvBer2.Count), _
xlValues, xlWhole, xlLeftToRight, xlNext)
If Not (zfb1 Is Nothing Or zfb2 Is Nothing) Then
ix = 0
While zfb1.Row > ix
ix = zfb1.Row: lb = 0
While zfb2.Column > lb
lb = zfb2.Column
'                    zSh.Cells(ix + zbZlVsatz, lb).ClearContents
zSh.Cells(ix + zbZlVsatz, lb).Interior.Color = vbRed
Set zfb2 = zvBer2.FindNext(zfb2)
Wend
Set zfb1 = zvBer1.FindNext(zfb1)
Wend
End If
nx: Next qvb
Set qSh = Nothing: Set zfb1 = Nothing: Set zvBer1 = Nothing
Set zSh = Nothing: Set zfb2 = Nothing: Set zvBer2 = Nothing
End Sub

Dabei wird zuerst ein spezielles Datenfeld aus den beiden Spalten von Tab3 gebildet und zwar als Vektor dessen Elemente ebenfalls aus Vektoren mit jeweils den beiden Werten einer Zeile bestehen, da die ja nur gemeinsam, quasi im Verbund, mit den jeweils anderen vgln wdn sollen.
Anschld wird dieser Vektor elementweise durchlaufen, wobei die Laufvariable stets einen Vektor repräsentiert, der die jeweils benötigten beiden Werte enthält. Diese wdn dann in den beiden unterschiedl orientierten VglsBereichen, jeder in seinem, mit der .Find/.FindNext-Methode gesucht und zwar zu jedem Treffer im senkrechten VglsBereich alle Treffer im waagerechten.
Das kannst du ja mal ausprobieren und, wenn alles richtig ist, die Färbe- de- und die Löschzeile aktivieren.
Falls dir Erichs Pgm verständlicher ist und dir seine Dauer nicht zu lang ist, kannst du natürlich auch das verwenden. Alle anderen dauern viel zu lange. Auf jeden Fall ist das, was du neuerdings vorhast, unnötig und höchstwahrscheinlich nicht wesentlich schneller.
Gruß Luc :-?

Public Sub x_loeschen1() Dim i As Long, s As Long, z As Long With Sheets(2) For i = 15 To 136 For z = 19 To 509 If Sheets(3).Cells(i, 3).Value = .Cells(z, 2).Value Then For s = 6 To 100 If Sheets(3).Cells(i, 6).Value = .Cells(13, s).Value Then .Cells(z + 3, s).Interior.Color = vbGreen End If Next s End If Next z Next i End With End Sub

Public Sub x_loeschen4() Dim rngL As Range, pS2B As Long, p13S2 As Long Dim i As Long, s As Long, z As Long Dim arS3C, arS3F, arS2B, ar13S2 Const rS3C$ = "C15:C136" ' Sheet 3 Sp. C Const rS3F$ = "F15:F136" ' Sheet 3 Sp. F Const rS2B$ = "B19:B509" ' Sheet 2 Sp. B Const r13S2$ = "F13:CV13" ' Sheet 2 Ze. 13 Const zVsatz As Long = 3 With Sheets(2) ar13S2 = .Range(r13S2).Value ' Sp.6-100 Z.13 arS2B = .Range(rS2B).Value ' Sp.B Z.19:509 arS3C = Sheets(3).Range(rS3C).Value ' Sp.C Z.15:136 arS3F = Sheets(3).Range(rS3F).Value ' Sp.F Z.15:136 pS2B = .Range(rS2B).Row - 1 p13S2 = .Range(r13S2).Column - 1 For i = 1 To UBound(arS3C) For z = 1 To UBound(arS2B) If arS3C(i, 1) = arS2B(z, 1) Then For s = 1 To UBound(ar13S2, 2) If arS3F(i, 1) = ar13S2(1, s) Then If rngL Is Nothing Then Set rngL = .Cells(z + pS2B + zVsatz, s + p13S2) Else Set rngL = Union(rngL, .Cells(z + pS2B + zVsatz, s + p13S2)) End If End If Next s End If Next z Next i If Not rngL Is Nothing Then rngL.Interior.Color = vbRed End With End Sub

Public Sub x_loeschen5() Dim rngL As Range, pS2B As Long, p13S2 As Long Dim i As Long, s As Long, z As Long Dim arS3C, arS3F, arS2B, ar13S2 Dim eDic As Object, arF() As Long, strK As String Const rS3C$ = "C15:C136" ' Sheet 3 Sp. C Const rS3F$ = "F15:F136" ' Sheet 3 Sp. F Const rS2B$ = "B19:B509" ' Sheet 2 Sp. B Const r13S2$ = "F13:CV13" ' Sheet 2 Ze. 13 Const zVsatz As Long = 3 Set eDic = CreateObject("Scripting.Dictionary") ReDim arF(0) With Sheets(2) ar13S2 = .Range(r13S2).Value ' Sp.6-100 Z.13 arS2B = .Range(rS2B).Value ' Sp.B Z.19:509 arS3C = Sheets(3).Range(rS3C).Value ' Sp.C Z.15:136 arS3F = Sheets(3).Range(rS3F).Value ' Sp.F Z.15:136 pS2B = .Range(rS2B).Row - 1 p13S2 = .Range(r13S2).Column - 1 ' Treffer Sp. B in Dict For i = 1 To UBound(arS3C) For z = 1 To UBound(arS2B) If arS3C(i, 1) = arS2B(z, 1) Then strK = arS3C(i, 1) If eDic.Exists(strK) Then arF = eDic(strK) ReDim Preserve arF(UBound(arF) + 1) arF(UBound(arF)) = z + pS2B + zVsatz Else ReDim arF(0) arF(0) = z + pS2B + zVsatz End If eDic(strK) = arF End If Next z Next i ' Check Zeile 13 For i = 1 To UBound(arS3C) For s = 1 To UBound(ar13S2, 2) If arS3F(i, 1) = ar13S2(1, s) Then If eDic.Exists(arS3C(i, 1)) Then ' Treffer in Dict? arF = eDic(arS3C(i, 1)) For z = 0 To UBound(arF) If rngL Is Nothing Then Set rngL = .Cells(arF(z), s + p13S2) Else Set rngL = Union(rngL, .Cells(arF(z), s + p13S2)) End If Next z End If End If Next s Next i If Not rngL Is Nothing Then rngL.Interior.Color = vbRed End With End Sub

…schneller als mein Pgm, Erich,
was daran liegen wird, dass für ein vglbares Array in einem separaten Durchlauf Indizes erst gebildet wdn mussten. Außerdem habe ich die Zellen direkt gefärbt, was der HptGrd sein dürfte. Wenn ich das jetzt auch noch optimieren wollte, könnte man Performance-Unterschiede sicher nur noch bei einer wesentlich größeren Datenmenge feststellen, aber ob dann Union noch mitspielen würde…?
Übrigens musste ich die Deklaration von strK auf Double (bzw Long) ändern, weil es sonst nicht fktioniert hätte, weil bei mir arS3C(i, 1) Zahlen liefert.
Was den Spaß betrifft — den meisten hab' ich, wenn ich was Neues entdecke, besonders, wenn es noch nirgends erwähnt wird… ;-]
Deshalb auch wollte ich mich hierbei gar nicht so engagieren, was meinen etwas schlampigen Einstand erklären mag… ;-)
Gruß + schöSo auch dir, Erich, Luc :-?

Beliebteste Forumthreads (12 Monate)

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread