VBA Löschen von Doppelten

Hallo,
ich bin gerade dabei mittels Macroaufzeichner etwas in das Thema VBA reinzurutschen. :) Nicht einfach aber ich werde mich da lasngsam reinfuchsen.
Nun Habe ich mir bereits ein erstes Marko erstellt das ich leider nicht abschließen kann, da mir halt viel know how fehlt.
Folgende Situation:
Ich habe eine Rangliste. In dieser stehen Name, Vorname, Punkte und Wertungen (Spalte B, C , E und F)
Die Rangliste ändert sich nach jedem Wettkampf. Wir lesen also die Wertungen in die Tabelle und hinterlegen die neuen Werte (Spalte A-F) mit einer Farbe. Das Marko sortiert nun schonmal autoamtisch nach Nach und Vornamen und addiert die Werte in Punkte und Wertungen, wenn eine Dopplung vorliegt. Jetzt will ich jedoch, dass das Marko nach der Addition die doppelten löscht. In dem Fall ist das die Gelb hinterlegte Spalte.
Besonderheit, es kann natürlcih sein, dass es einen Teilnehmer gibt, der Gelb hinterlegt ist aber das erste mal in die Wertung kommt. Somit muss dort dann der Gelbe hintergrund weg. Das bekomme ich aber wieder selber hin mittels Aufzeichung. Der Hinweis ist nur dafür, dass nicht einfach alle gelb hinterlegten Spalten gelöscht werden dürfen
Bin mir sicher, dass ich hier die nötige Hilfe bekomme.
Danke
Robert

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi Robert,
das sollte taugen, oder?

Option Explicit
Sub RemYellowDoubles()
Dim lRowFirst As Long
Dim lRowLast
Dim lName As Long
Dim rVerbund As Range
Dim iCol As Integer
Dim lYellow As Long
Application.ScreenUpdating = False
With ActiveSheet
lRowFirst = 4                   'ab Zeile 4 gehts los, drüber sind Überschriften
iCol = 2                        'Namen stehen in Spalte 2 = Spalte B
Set rVerbund = .Range("G4:G23") 'Der Zellenverbund rechts von der Tabelle
lYellow = 65535                 'Farbwert GELB = 65535
'Zeilenverbund aufheben
rVerbund.MergeCells = False
'letzte Zeile
lRowLast = .Cells(Rows.Count, iCol).End(xlUp).Row
'alle Namen rückwärts durchlaufen
For lName = lRowLast To lRowFirst Step -1
'Prüfe Hintergrundfarbe
If .Cells(lName, iCol).Interior.Color = lYellow Then
'Prüfe Namen auf doppelt vorhanden
If Application.WorksheetFunction.CountIf(.Range(.Cells(lRowFirst, iCol), .Cells( _
lRowLast, iCol)), .Cells(lName, iCol).Value) > 1 Then
'lösche die ganze Zeile
.Cells(lName, iCol).EntireRow.Delete shift:=xlUp
End If
End If
Next lName
'Zeilenverbund wieder setzen
rVerbund.MergeCells = True
End With
Application.ScreenUpdating = True
End Sub

Grüße,
Klaus M.vdT.

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread