Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

farbig markierte Zellen in zwei Spalten vergleiche

farbig markierte Zellen in zwei Spalten vergleiche
07.11.2018 16:30:27
Peter
Hallo ihr Excelspezialisten,
ich habe eine Tabelle3 mit Spalte B und Spalte J mit dem nachstehenden Makro suche ich in der Spalte B einen Wert aus Spalte A und markiere die gefundenen Werte in den Spalten B und J rot.
Sub Kopierernamen_finden_färben()
Dim ws As Range, Zelle As Range, Bereich As Range, Wert1 As Range, Wert2 As Range
Set ws = Range("C2")
Set Wert1 = Range("A5")
ws.Activate
Set Bereich = Range("B2:B20")
For Each Zelle In Bereich
Select Case Zelle.Value
Case Wert1:
Zelle.Interior.ColorIndex = 3
Zelle.Offset(0, 8).Interior.ColorIndex = 3
End Select
Next Zelle
End Sub

In der Spalte B können doppelte Werte vorhanden sein in der Spalte J hingegen nicht.
Wenn in der Spalte J doppelte Werte gefunden werden, sollen die Zellen in Spalte B und J gelöscht werden.
Ausserdem soll eine Schleife vorhanden sein, dass alle Werte in Spalte A diesen Prozess durchlaufen.
Könnt ihr mir bitte hierbei behilflich sein.
Besten Dank
Gruss
Peter

14
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
wei Spalten vergleichen
07.11.2018 18:04:03
Peter
Hallo ihr Excelspezialisten,
ich habe jetzt das Makro soweit fertig, dass die Spalte A durchlaufen wird und die Zellen in Spalte B und J rot eingefärbt werden.
Sub Makro2()
Dim Zelle1 As Range
Dim Zelle2 As Range
Dim Bereich1 As Range
Dim Bereich2 As Range
Dim Wert1 As String
Worksheets("Tabelle5").Activate
Set Bereich2 = Range("B2:B20")
Set Bereich1 = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
For Each Zelle1 In Bereich1
Wert1 = Zelle1.Value 'funktioniert
For Each Zelle2 In Bereich2
Select Case Zelle2.Value
Case Wert1:
Zelle2.Interior.ColorIndex = 3
Zelle2.Offset(0, 8).Interior.ColorIndex = 3
'hier prüfung doppelte einfügen ggf löschen
End Select
Next Zelle2
MsgBox Zelle1
Next Zelle1
End Sub
Was mir jetzt noch fehlt, ist die Prüfung ob bei den rot eingefärbten Zellen in Spalte J im Vergleich zu Spalte B doppelte Einträge vorhanden sind. Wenn dies der Fall ist sollen die Zellen in J und B gelöscht werden.
Könnt ihr mir bitte bei dieser Prüfung helfen.
Besten Dank
Gruss
Peter
Anzeige
Und warum....
07.11.2018 21:59:45
Werner
Hallo Peter,
...zeigst du uns deine Datei nicht indem du sie hier hochlädst?
Gruß Werner
AW: Und warum....
08.11.2018 07:36:20
Peter
Guten Morgen Werner,
anbei die Datei: https://www.herber.de/bbs/user/125254.xlsm
Die genaue Beschreibung befindet sich auf der Hilfstabelle.
Besten Dank für Deine Hilfe.
Gruss
Peter
AW: Und warum....
08.11.2018 11:36:26
Werner
Hallo Peter,
tolle Beispielmappe.
In deiner Beschreibung Doppler anhand der Spalten B und J, in der Beispielmappe Doppler anhand der Spalten B und C.
Was jetzt?
Und dann stellt sich mir die Frage, ob das für alle Werte im Blatt Kontodaten durchgeführt werden soll, also ahnand des Beispiels für Holz, Stein, Erde, Baum.
Gruß Werner
Anzeige
AW: Lösung gefunden
08.11.2018 11:38:35
Peter
Hallo Werner,
besten Dank für Deine Bemühungen
habe die Lösung zwischenzeitlich mit Hilfe des Archivs und eigenen Umbauten selbst gefunden.
Gruss
Peter
Schön...
08.11.2018 11:44:34
Werner
Hallo Peter,
...dann interessiert dich meine Version wohl nicht mehr, auch gut.
Aber noch was:
Du scheinst den Sinn eines derartigen Forums nicht verstanden zu haben, denn warum sonst stellst du deine Lösung des Problems hier nicht ein?
So kann kein User davon profitieren, der ein ähnliches Problem auch hat.
Du hättest dann auch keine Lösung gefunden, wenn das nicht eingestellt worden wäre.
Gruß Werner
Anzeige
AW: meine Lösung
08.11.2018 11:56:09
Peter
Hallo Werner,
Option Explicit
Sub doppelte_Zellen_SpalteCundD_entfernen()
Dim lngZeile As Long                    'benötigt für Einfärben der doppelten Zellen
Application.ScreenUpdating = False
For lngZeile = 1 To Cells(65536, 4).End(xlUp).Row 'benötigt für Einfärben der doppelten  _
Zellen
'Anfang doppelte Zellen einfärben
If Cells(lngZeile, 4) = Cells(lngZeile + 1, 4) And Cells(lngZeile, 3) = Cells(lngZeile + _
1, 3) Then
'Einfärben SpalteD doppelte
With Range(Cells(lngZeile, 4), Cells(lngZeile + 1, 4))
.Font.ColorIndex = 3
End With
'Einfärben SpalteC doppelte
With Range(Cells(lngZeile, 3), Cells(lngZeile + 1, 3))
.Font.ColorIndex = 3
End With
End If
Next
'Ende doppelte Zellen einfärben
'löscht erste gefärbte Zelle Spalte C
Call SpalteC_wähltErstegefärbteZellevonunten_löschen2
'löscht erste gefärbte Zelle Spalte D
Call SpalteD_wähltErstegefärbteZellevonunten_löschen2
'ändert Schriftfarbe von rot auf scharz in Spalten C und D
Call Schriftfarbe_ändern_schwarz2
Application.ScreenUpdating = True
End Sub

'ausgeführt in Makro "doppelte_Zellen_SpalteCundD_entfernen"
Sub SpalteC_wähltErstegefärbteZellevonunten_löschen2()
Dim a As Long                                       'benötigt für erste gefärbte Zelle von  _
unten löschen Spalte C
For a = Range("c65536").End(xlUp).Row To 1 Step -1  'benötigt für erste gefärbte Zelle von  _
unten löschen Spalte C
'Anfang für erste gefärbte Zelle von unten löschen Spalte C
If Cells(a, 3).Font.ColorIndex = 3 Then
'löscht die erste gefärbte Zelle von unten Spalte C
Cells(a, 3).Delete Shift:=xlUp
Exit Sub
End If
Next a
'Ende für erste gefärbte Zelle von unten löschen Spalte C
End Sub
'ausgeführt in Makro "doppelte_Zellen_SpalteCundD_entfernen"
Sub SpalteD_wähltErstegefärbteZellevonunten_löschen2()
Dim a As Long                                       'benötigt für erste gefärbte Zelle von  _
unten löschen Spalte C
For a = Range("D65536").End(xlUp).Row To 1 Step -1  'benötigt für erste gefärbte Zelle von  _
unten löschen Spalte C
'Anfang für erste gefärbte Zelle von unten löschen Spalte D
If Cells(a, 4).Font.ColorIndex = 3 Then
'löscht die erste gefärbte Zelle von unten Spalte D
Cells(a, 4).Delete Shift:=xlUp
Exit Sub
End If
Next a
'Ende für erste gefärbte Zelle von unten löschen Spalte D
End Sub

'ausgeführt in Makro "doppelte_Zellen_SpalteCundD_entfernen"
Sub Schriftfarbe_ändern_schwarz2()
'Anfang Schriftfarbe in scharz ändern
'SpalteC
With Range(Cells(2, 3), Cells(Rows.Count, 3).End(xlUp)).Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
'SpalteD
With Range(Cells(2, 4), Cells(Rows.Count, 4).End(xlUp)).Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
'Ende Schriftfarbe in scharz ändern
End Sub
Wünsche noch einen schönen Tag.
Gruss
Peter
Anzeige
und hier meine....
08.11.2018 12:30:12
Werner
Hallo Peter,
...auch wenn es dich wohl nicht wirklich interessiert. Aber vielleicht kann es ja jemand mal brauchen.
Die Begriffe im Blatt "Kontodaten" werden abeklappert. Für jeden Begriff wird Blatt "Hilfstabelle" auf Doppler in Spalte C und Spalte D überprüft und die Doppler werden gelöscht.
Option Explicit
Public Sub Test()
Dim loLetzte As Long, loLetzteKo As Long
Dim loSpalte As Long, i As Long
Dim strSuchbegriff As String
Application.ScreenUpdating = False
With Worksheets("Kontodaten")
loLetzteKo = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
With Worksheets("Hilfstabelle")
loSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
End With
For i = 2 To loLetzteKo
strSuchbegriff = """" & Worksheets("Kontodaten").Cells(i, 1) & """"
With Worksheets("Hilfstabelle")
loLetzte = .Cells(.Rows.Count, 3).End(xlUp).Row
.Range(.Cells(2, loSpalte), .Cells(loLetzte, loSpalte)).FormulaLocal = _
"=WENN(ZÄHLENWENNS(C:C;" & strSuchbegriff & ";C:C;C2;D:D;D2)>1;0;ZEILE())"
.Range(.Cells(2, loSpalte), .Cells(loLetzte, loSpalte)).Value = _
.Range(.Cells(2, loSpalte), .Cells(loLetzte, loSpalte)).Value
.Cells(1, loSpalte) = 1
.Range(.Cells(1, 3), .Cells(loLetzte, loSpalte)).RemoveDuplicates Columns:=loSpalte - 2, _
_
Header:=xlNo
.Columns(loSpalte).ClearContents
End With
Next i
End Sub
Gruß Werner
Anzeige
AW: und hier meine....
08.11.2018 18:23:09
Peter
Hallo Werner,
wie Du siehst habe ich sehr wohl meine Version eingestellt. Und selbstverständlich interessiert mich Deine Version. Ich werde diese selbstverständlich testen und Dir dann Bescheid geben.
Nochmals besten Dank.
Gruss
Peter
AW:funktioniert
09.11.2018 05:47:46
Peter
Hallo Werner,
vielen Dank für Deine Mühe. Deine Version funktioniert einwandfrei.
Das ist genau so wie ich es haben wollte. Alles in einem Makro. So ein Makro hätte ich als Laie nicht geschafft.
Ich werde Deine Version auf jeden Fall benutzen.
Trotzdem freue ich mich, dass ich selbst mit meiner Version zum gleichen Ziel gelange.
Nochmals vielen Dank und einen schönen Tag.
Gruss
Peter
Anzeige
AW: Zusatz möglich?
09.11.2018 08:13:27
Peter
Hallo Werner,
wie ich bereits mitgeteilt habe, funktioniert die Abfrage perfekt.
Ich habe diese zum Ausführen in der UF im Button "Übernahme Daten" eingefügt. Klappt einwandfrei.
Jetzt möchte ich gerne, wenn Doppelte gelöscht wurden, dass er diese als Meldung in Label anzeigt.
Wenn nichts gelöscht wurde, dann keine Meldung.
Die UF lautet UF_Kategorien, das Label ist Label15. Label15.caption="Eintrag doppelt - gelöscht"
Besten Dank für Deine Hilfe.
Gruss
Peter
AW: Zusatz möglich?
09.11.2018 09:14:26
Werner
Hallo Peter,
dann zum Beispiel so:
Option Explicit
Public Sub Test()
Dim loLetzte As Long, loLetzteKo As Long
Dim loSpalte As Long, loLetzteAlt As Long, i As Long
Dim strSuchbegriff As String
Application.ScreenUpdating = False
With Worksheets("Kontodaten")
loLetzteKo = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
With Worksheets("Hilfstabelle")
loLetzte = .Cells(.Rows.Count, 3).End(xlUp).Row
loSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
loLetzteAlt = loLetzte
End With
For i = 2 To loLetzteKo
strSuchbegriff = """" & Worksheets("Kontodaten").Cells(i, 1) & """"
With Worksheets("Hilfstabelle")
loLetzte = .Cells(.Rows.Count, 3).End(xlUp).Row
.Range(.Cells(2, loSpalte), .Cells(loLetzte, loSpalte)).FormulaLocal = _
"=WENN(ZÄHLENWENNS(C:C;" & strSuchbegriff & ";C:C;C2;D:D;D2)>1;0;ZEILE())"
.Range(.Cells(2, loSpalte), .Cells(loLetzte, loSpalte)).Value = _
.Range(.Cells(2, loSpalte), .Cells(loLetzte, loSpalte)).Value
.Cells(1, loSpalte) = 1
.Range(.Cells(1, 3), .Cells(loLetzte, loSpalte)).RemoveDuplicates _
Columns:=loSpalte - 2, Header:=xlNo
.Columns(loSpalte).ClearContents
End With
Next i
With Worksheets("Hilfstabelle")
loLetzte = .Cells(.Rows.Count, 3).End(xlUp).Row
If loLetzteAlt > loLetzte Then
Me.Label15.Caption = "Eintrag doppelt - gelöscht"
Else
Me.Label15.Caption = "Keine doppelten Einträge"
End If
End With
End Sub
Gruß Werner
Anzeige
AW: Zusatz funktioniert
09.11.2018 11:02:53
Peter
Hallo Werner,
besten Dank für Deine Hilfe. Es funktioniert super!!!
Gruss
Peter
Gerne u. Danke für die Rückmeldung. o.w.T.
09.11.2018 11:23:39
Werner

303 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige