Office: VBA duplikate finden und auf Kriterien prüfen

Liebe Excel Gemeinschaft

Ich möchte gerne mit VBA code
Doppelte Einträge finden und 2 Kriterien sollen Geprüft werden un anderen spalte. Zu guter letzte sollte in einer weiter die Ausweisung/Textresultat stehen.

spalte D (Artikelnummern 51541, 51541 , 51542, 51544 usw.)
zuerst hier die duplikate finden

Sobald ein Duplikat gefunden wurde
Z.b 51541 - sollte in Spalte B nach 2 Kriterien gesucht werden und zwar „Web“ und „Flyer“ , welche jeweils in spalte B als Text abgebildet sind und z.B:
Spalte B / Spalte D
1. Werbung november Flyer / 51541
2. Werbung november Web / 51541


Sind die beiden Kriterien vorhanden/erfüllt, dann bitte in Spalte C mit Text ergänzen/ausweisen „web und flyer“. Hier das Beispiel:


Spalte B / Spalte C / Spalte D
1. Werbung november Flyer/ Web und Flyer / 51541
2. Werbung november Web / Web und Flyer/ 51541


Ich hoffe auf eine super einfache VBA Makro lösung und bin offen für Ideen.

Für eure Zeit und eure Hilfe bedanke ich mich im Voraus und bin gespannt auf die Lösung.

 

Excel VBA-Forum - Das Forum zu Microsoft Excel VBA

Excel2019 - Excel VBA Duplikate finden plus Kriterien prüfen und Wert in andere Spalte - MS-Office-Forum

 

Lieber Super Moderator - nun ich werde die restlichen Beiträge schliessen und hoffe hier antwort zu finden

 

Nein, das musst du nicht. Das soll den Helfern nur eine Gelegenheit bieten nachzuschauen, ob es irgendwo anders schon Lösungen gibt.

 

Hallo,

nachfolgend das Makro "DupKrit", das die gewünschten Überprüfungen und Modifikationen durchführt.
Es ist in ein allgemeines Codemodul zu kopieren und kann zB. mit der Tastenkombination Alt+F8 ausgewählt werden.
Der Bereich für die Spalte D ist an deine Verhältnisse anzupassen (ist im Makro zurzeit D10:D100).

Code:

Option Explicit

Sub DupKrit()
    Dim rngSpalteD As Range, lngSpalteD1 As Long, lngSpalteDAnz As Long
    Dim rngSpalteDRest As Range, lngSpalteD1Rest As Long
    Dim rngTest As Range
    Dim lngDupRow As Long, r1 As Long, r2 As Long
  
    Set rngSpalteD = Range("D10:D100")  '<-- Bereich von Spalte D: Anpassen!
    lngSpalteD1 = rngSpalteD.Row
    lngSpalteDAnz = rngSpalteD.Rows.Count
  
    On Error GoTo Err_NoDupFound
    For Each rngTest In rngSpalteD.Cells
       lngSpalteD1Rest = rngTest.Row - lngSpalteD1 + 1
       Set rngSpalteDRest = rngSpalteD.Offset(lngSpalteD1Rest, 0).Resize(lngSpalteDAnz - lngSpalteD1Rest)
      
       lngDupRow = WorksheetFunction.Match(rngTest.Value, rngSpalteDRest, 0)
       'Duplikat wurde gefunden
       'Debug.Print rngTest.Row, lngDupRow + lngSpalteD1Rest + lngSpalteD1 - 1
      
       'Testen, ob in Spalte B "Web" bzw. "Flyer" enthalten ist in den Duplikatszeilen:
       r1 = rngTest.Row: r2 = lngDupRow + lngSpalteD1Rest + lngSpalteD1 - 1
       If Cells(r1, 2) Like "*Web*" Or Cells(r1, 2) Like "*Flyer*" Then
         If Cells(r2, 2) Like "*Web*" Or Cells(r2, 2) Like "*Flyer*" Then
            'Falls in Spalte B "Web" bzw. "Flyer" enthalten, in Spalte C "Web und Flyer" ergänzen
            Cells(r1, 3).Value = Cells(r1, 3) & "Web und Flyer"
            Cells(r2, 3).Value = Cells(r2, 3) & "Web und Flyer"
         End If
       End If
Nxt_NoDupFound:
    Next rngTest
    Exit Sub
Err_NoDupFound:
    Resume Nxt_NoDupFound
End Sub