Liste ohne doppelte u. bestimmte Wörter

Hallo zusammen
Heute habe ich mal ein etwas größeres Anliegen. In der Beispielmappe stehen in Spalte B Namen und rot geschriebene Worte (über bedingte Formatierung) wie geplante_Zeit, Noch_frei etc.
Diese Spalte hätte ich gerne ausgelesen via CommandButton, ohne Doppelte und ohne die rot geschriebenen Worte.
Jetzt kommt aber, wozu ich nichts finde.
In Tabelle 1 werden immer noch Namen hinzugefügt oder gelöscht.
In Tabelle 2 werden zu den einzelnen Namen in Spalte C, D, usw. noch weitere Daten hinzugefügt.
Das heißt einmal ausgelesen sollen neu hinzugekommene ausschließlich unten angefügt werden, sonst passen ja die hinten angefügten ausgefüllten Zellen nicht mehr zu den Namen. Gelöschte Namen sollen entfernt werden (Da dürfen die Zeilen, gerne einfach leer bleiben.
Ich hoff ich habe es einigermaßen verständlich geschrieben, woran ich verzweifle. Ich habe in der Beispielmappe mal n paar Daten händisch einfügt. Ich kann leider die original Datei aufgrund der enthaltenen Daten nicht hochladen
https://www.herber.de/bbs/user/153156.xlsx
Gruß Gerhard

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub tt() Dim TB1 As Worksheet, TB2 As Worksheet, i As Long Dim Sp As Integer, ZE As Integer, LR1 As Long, LR2 As Long '*** bescheunigt das Makro Application.ScreenUpdating = False '*** Stammdaten Anfang Set TB1 = Sheets("Tabelle1") Set TB2 = Sheets("Tabelle2") Sp = 2 'Spalte B ZE = 12 'Daten stehen ab Zeile '*** Stammdaten Ende With TB1 LR1 = .Cells(.Rows.Count, Sp).End(xlUp).Row 'letzte Zeile der Spalte LR2 = TB2.Cells(TB2.Rows.Count, Sp).End(xlUp).Row 'Prüfen auf Neue For i = ZE To LR1 Select Case .Cells(i, Sp) Case "", "Geplante_Zeit", "Noch_frei" 'mach nix Case Else If WorksheetFunction.CountIf(TB2.Columns(Sp), .Cells(i, Sp)) = 0 Then 'noch nicht vorhanden TB2.Cells(LR2 + 1, Sp) = .Cells(i, Sp) LR2 = LR2 + 1 End If End Select Next 'Prüfen auf Gelöschte For i = ZE To LR2 If WorksheetFunction.CountIf(.Columns(Sp), TB2.Cells(i, Sp)) = 0 Then 'nicht mehr vorhanden TB2.Rows(i).ClearContents End If Next End With End Sub

Hallo nochmal
Also immer A bis C...
dann so


Private Sub tt()
Dim TB1 As Worksheet, TB2 As Worksheet, i As Long
Dim ZE As Integer, LR1 As Long, LR2 As Long
'*** bescheunigt das Makro
Application.ScreenUpdating = False
'*** Stammdaten Anfang
Set TB1 = Sheets("Tabelle1")
Set TB2 = Sheets("Tabelle2")
ZE = 12 'Daten stehen ab Zeile
'*** Stammdaten Ende
With TB1
LR1 = .Cells(.Rows.Count, "B").End(xlUp).Row 'letzte Zeile der Spalte
LR2 = TB2.Cells(TB2.Rows.Count, "B").End(xlUp).Row
'Prüfen auf Neue
For i = ZE To LR1
Select Case .Cells(i, 2)
Case "", "Geplante_Zeit", "Noch_frei"
'mach nix
Case Else
If WorksheetFunction.CountIf(TB2.Columns(2), .Cells(i, 2)) = 0 Then 'noch nicht vorhanden
TB2.Cells(LR2 + 1, 1).Resize(1, 3).Value = .Cells(i, 1).Resize(1, 3).Value
LR2 = LR2 + 1
End If
End Select
Next
'Prüfen auf Gelöschte
For i = ZE To LR2
If WorksheetFunction.CountIf(.Columns(2), TB2.Cells(i, 2)) = 0 Then 'nicht mehr vorhanden
TB2.Rows(i).ClearContents
End If
Next
End With
End Sub

LG UweD

Beliebteste Forumthreads (12 Monate)

Liste ohne doppelte u. bestimmte Wörter

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Liste ohne doppelte u. bestimmte Wörter

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread