Automatischer sheet Eintrag

Hallo Ihr da draußen,
sitze schon den ganzen Nachmittag über einem Problem, von dem ich denke, dass es eine ganz schöne Nuss ist.

Die Datei https://www.herber.de/bbs/user/4865.xls wurde aus Datenschutzgründen gelöscht

Ich habe eine Excel Tabelle mit z.B. 5 sheets. In jedem der 4 sheet werden Namen von verschiedenen Teilnehmern eingetragen und im fünften sheet sollen alle Teilnehmer aus allen 4 sheets automatisch erscheinen. Allerdings kann es passieren, dass in 2 der 4 sheets ein Teilnehmer doppelt erscheint. Dies soll in dem fünften sheet durch eine Info (z.B. rot markiert) deutlich werden, so, dass die Person aus einem sheet entfernt werden kann (bei bedarf).
Zusätzlich muß natürlich die Info im fünften sheet da sein, woher die jeweiligen Personen kommen.
Hoffentlich könnt Ihr mir helfen diese Nuss zu knacken.
Vielen Dank im voraus.
Cris

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hi Cris
Und hier etwas mit VBA...
Option Explicit


Sub Machmal()
Dim iBlatt As Byte
Dim iZeile As Long, iiZeile As Long
Dim Zusammen As Worksheet, WS As Worksheet
Dim Vorhanden As Boolean
Set Zusammen = Worksheets("Zusammenfassung")
Zusammen.Range("A2:F65536").Delete
For iBlatt = 2 To 5
Set WS = Worksheets(iBlatt)
For iZeile = 2 To WS.Range("A65536").End(xlUp).Row
Vorhanden = False
For iiZeile = 2 To Zusammen.Range("A65536").End(xlUp).Row
If Zusammen.Cells(iiZeile, 1) = WS.Cells(iZeile, 1) And _
Zusammen.Cells(iiZeile, 2) = WS.Cells(iZeile, 2) Then
Vorhanden = True
Exit For
End If
Next iiZeile
If Vorhanden = True Then
Zusammen.Cells(iiZeile, iBlatt + 1) = "x"
Else
Zusammen.Cells(iiZeile, 1) = WS.Cells(iZeile, 1)
Zusammen.Cells(iiZeile, 2) = WS.Cells(iZeile, 2)
Zusammen.Cells(iiZeile, iBlatt + 1) = "x"
End If
Next iZeile
Next iBlatt
With Zusammen.Range("A2:F" & iiZeile)
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=WENN(ZÄHLENWENN($A2:$F2;""x"")>1;WAHR;)"
.FormatConditions(1).Font.ColorIndex = 3
End With
End Sub

Gruss
Chris

Sub Cris() Range(Cells(2, 1), Cells(Cells(65536, 1).End(xlUp).Row, 6)).Font.ColorIndex = 0 Range(Cells(2, 1), Cells(Cells(65536, 1).End(xlUp).Row, 6)).ClearContents For w = 2 To 5 With Sheets(w) For z = 2 To .Cells(65536, 1).End(xlUp).Row r = Cells(65536, 1).End(xlUp).Row + 1 sFind2 = .Cells(z, 2) Set C = Sheets(1).Columns(2).Find(sFind2, LookIn:=xlValues, LookAt:=xlWhole) If Not C Is Nothing Then x = 1 sFind1 = .Cells(z, 1) Set C = Sheets(1).Columns(1).Find(sFind1, LookIn:=xlValues, LookAt:=xlWhole) If Not C Is Nothing Then x = x + 1 If x = 2 Then Range(C(1, 1), C(1, 6)).Font.ColorIndex = 3 C(1, w + 1) = "x" x = "" Else Cells(r, 1) = .Cells(z, 1) Cells(r, 2) = .Cells(z, 2) Cells(r, w + 1) = "x" End If Next z End With Next w End Sub

Beliebteste Forumthreads (12 Monate)

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread