Löschen Duplikate anhand der ersten vier Zeichen
07.07.2015 13:37:07
Conelius
ich benötige eure VBA-Programmierhilfe, weil ich mit meinen Kenntnissen am Ende angelangt bin.
Ich habe eine Tabelle (Spalte A) die wie folgt aussieht.
M01_Ø72 H9
M02_Rundheit 0,05
M04_Abstand 10,2_Z
M05_Ø123
M09_MzR Mh-16,0
M09_MzR Mh-36,3
M10_MueR Mh-7,0
M19_Ø205,4
M20_Ø205,4
M21_Ø205,4
M01_Ø72H9 72,000-72,074
M01a_Ø72H9 Lehrdornpruefung
M02_Rundh. 0,05
M03_Dicke 3,00-3,12
M04_Abst. 10,10-10,30
In Spalte B befinden sich entweder konkrete Messwerte oder eine "0".
Nun möchte ich aus Spalte A die Zeilen löschen, die Duplikate der Merkmale enthalten. Ein Duplikat soll vorliegen, wenn die ersten vier Zeichen des Zellinhalts übereinstimmen. Es sollen jedoch nur die Duplikate gelöscht werden, welche in der Spalte B den Wert 0 enthalten
Mein bisheriges Makro löscht die Duplikate unabhängig vom Zellinhalt der Spalte B. D.h. teilweise werden Merkmale mit Messwerten gelöscht und die mit dem Wert 0 in Spalte B bleiben erhalten.
'Mein Programmcode (aus dem Internet, leicht modifiziert und zu komplex für mich):
Dim objDic As Object: Set objDic = CreateObject("Scripting.Dictionary")
Dim ber As Range, berDel As Range, i As Long, tmpRow As Long, arber
With ActiveSheet
Set ber = .Range(.Cells(2, 5), .Cells(.Rows.Count, 1).End(xlUp))
End With
arber = ber
For i = 10 To 85
If objDic.exists(Left$(arber(i, 1), 4)) Then
tmpRow = objDic.Item(Left$(arber(i, 1), 4))
If berDel Is Nothing Then Set berDel = ber(i, 1) _
Else Set berDel = Union(berDel, ber(i, 1))
Else
objDic.Add Left$(arber(i, 1), 4), i
End If
Next i
ber = arber
If Not berDel Is Nothing Then berDel.EntireRow.Delete
End Sub
Freue mich über jegliche Hilfestellung. :)
Beste Grüße
Cornelius