Duplikate aus Tabelle entfernen

Hallo an euch alle,
ich hoffe ihr habt bei folgender Tabelle eine Lösung.
https://www.herber.de/bbs/user/103531.xlsx
Es geht mir darum, dass Stadt A als Start angesehen werden soll und die Städte in H - K als Ziele, die von dieser Stadt aus zu erreichen sind.
Es geht mir darum Verbindungen, die mehrfach vorkommen zu löschen.
die erste Verbindung ist z.B. Aachen nach Maastricht (A1;H1)
diese Verbindung kommt auch in umgekehrter Fahrtrichtung von Maastricht nach Aachen vor, (A183; I183). In diesem Fall soll "Aachen" aus der Zelle I183 gelöscht werden.
die zweite Verbindung ist z.B. Aachen nach Bonn (A1;I1)
In der Tabelle gibt es keine Verbindung von Bonn nach Aachen, also soll hier nichts geschehen.
die dritte Verbindung ist z.B. Aachen nach Lüttich (A1;J1)
In der Tabelle gibt es auch keine Verbindung von Lüttich nach Aachen, also soll auch hier nichts geschehen.
die vierte Verbindung ist z.B. Aachen nach Köln (A1;K1)
diese Verbindung kommt auch in umgekehrter Fahrtrichtung von Köln nach Aachen vor, (A155; J155). In diesem Fall soll "Aachen" aus der Zelle J155 gelöscht werden.
Hoffe das war genug an Beispielen, also wenn eine Verbindung in beiden Fahrtrichtungen in der Tabelle steht, soll sie das erste mal erhalten bleiben und die zweite Verbindung soll gelöscht werden.
Hat da jemand eine Lösung?
Viele Grüße und vielen Dank
Christian

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

' ********************************************************************** ' Modul: Modul1 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub removeDuplikates() Dim varA As Variant, varB As Variant, varRet As Variant Dim lngLast As Long, lngR As Long, lngC As Long, lngI As Long With Tabelle1 'Sheets("Tabelle1") 'Activesheet lngLast = .Cells(.Rows.Count, 1).End(xlUp).Row varA = Range("A1:A" & lngLast) varB = Range("H1:K" & lngLast) For lngR = 1 To UBound(varB, 1) For lngC = 1 To UBound(varB, 2) varRet = Application.Match(varB(lngR, lngC), varA, 0) If IsNumeric(varRet) Then For lngI = 1 To UBound(varB, 2) If varB(varRet, lngI) = varA(lngR, 1) Then varB(varRet, lngI) = "" Next End If Next Next .Range("H1").Resize(UBound(varB, 1), UBound(varB, 2)) = varB End With End Sub

' ********************************************************************** ' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...) ' ********************************************************************** Option Explicit Sub removeDuplikates() Dim varA As Variant, varB As Variant, varRet As Variant Dim lngLast As Long, lngR As Long, lngC As Long, lngI As Long With Me lngLast = .Cells(.Rows.Count, 1).End(xlUp).Row varA = .Range("A1:A" & lngLast) varB = .Range("H1:K" & lngLast) For lngR = 1 To UBound(varB, 1) For lngC = 1 To UBound(varB, 2) varRet = Application.Match(varB(lngR, lngC), varA, 0) If IsNumeric(varRet) Then For lngI = 1 To UBound(varB, 2) If varB(varRet, lngI) = varA(lngR, 1) Then varB(varRet, lngI) = "" Next End If Next Next .Range("H1").Resize(UBound(varB, 1), UBound(varB, 2)) = varB End With End Sub

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

58 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Duplikate aus Tabelle entfernen

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

58 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread