Excel Makro VBA | Zelleninhalt blattübergreifend vergleichen und ausgeben?
Guten Tag,
ich habe ewig im Netz gesucht aber nix passendes gefunden.
Ich würde gerne eine große Tabelle arbeitsblattübergreigend vergleichen. Je Woche wird hierzu ein neues Blatt eröffnet, in welcher sich eine Tabelle befindet, welche zum Teil andere Werte besitzt. Nun sollen die einzelne Zellen(String, Text) von dem neuen Arbeitsblatt mit dem letzten (sprich dem links davon) verglichen werden und identische Zellen markiert werden.
Wie kann ich das umsetzten?
1 Antwort
Hallo,
dazu kannst du das folgende verwenden. Aktuell markiert es auch leere Zellen, falls das nicht gewünscht ist müsstest du in der if-Abfrage in der For Each-Schleife noch ein{ and zelle.value <> "" } hinzufügen.
Sub identMark()
Dim bereich As String
Dim zelle As Range, markBereich As Range
Dim farbe As Long, aktNummer As Long
'anpassen an deine Tabelle
bereich = "A1:B6"
farbe = RGB(0, 150, 255)
'festlegen von Zielbereich und Blattnummer
Set markBereich = ActiveSheet.Range(bereich)
aktNummer = ActiveSheet.Index
'Fehlerprüfung, falls es kein Blatt links des aktiven gibt
If aktNummer = 1 Then
MsgBox "Das erste Blatt ist aktiv, der Vorgang wurde abgebrochen"
Exit Sub
End If
'Zellen markieren
For Each zelle In markBereich
If ActiveWorkbook.Sheets(aktNummer - 1).Range(zelle.Address).Value = zelle.Value Then
zelle.Interior.Color = farbe
End If
Next
End Sub
Noch ein Hinweis: Falls es zwischen dem aktuellen und dem daneben ein ausgeblendetes Blatt gibt, wird dieses ausgeblendete Blatt für den Vergleich genutzt
Mach mall deinen Bereich OHNE Leerzeichen.
Ggf gibt es auch eine Maximale Länge, die man dort angeben darf. (Ggf zum Test mal verkürzen.
UND du musst das neue Sheet als "sichtbares" Sheet haben, bevor du dies startest. (Man könnte dies auch per "Bedingter Formatierung" machen.
Bitte :D
Das Problem liegt hier darin das du mehrere voneinander unabhängige Bereiche hast, Range aber nur für einen zusammenhängenden Bereich genutzt werden kann. Für mehrere verschiedene Bereiche habe ich .Union gefunden, Allerdings braucht das die Argumente als Range, d.h. man muss entweder bereits vorher die einzelnen Teilereiche händisch festlegen oder den String in einer Schleife nach und nach aufteilen und zum Gesamtbereich hinzufügen:
Sub identMark()
Dim bereich As String, aBer As String, bBer As String, nBer As String
Dim zelle As Range, gesBereich As Range
Dim farbe As Long, aktNummer As Long
'anpassen an deine Tabelle
bereich = "I21:I28, I31:I32, I36:I37, I40:I57, I63:I87, I119:I139, I204:I205, I231:I255, I262:I271, I277:I278, Q21:Q28, Q31:Q32, Q63:Q64, Q67:Q84, Q87:Q88, Q231:Q232, Q262:Q271, Q277:Q284"
farbe = RGB(0, 150, 255)
'festlegen von Zielbereich und Blattnummer
aktNummer = ActiveSheet.Index
If InStr(1, bereich, ",") > 0 Then
aBer = Trim(Left(bereich, InStr(1, bereich, ",") - 1))
bereich = Trim(Right(bereich, Len(bereich) - Len(aBer) - 1))
If InStr(1, bereich, ",") > 0 Then
bBer = Trim(Left(bereich, InStr(1, bereich, ",") - 1))
bereich = Trim(Right(bereich, Len(bereich) - Len(bBer) - 1))
Else
bBer = bereich
bereich = ""
End If
Set gesBereich = Application.Union(ActiveSheet.Range(aBer), ActiveSheet.Range(bBer))
Else
Set gesBereich = ActiveSheet.Range(bereich)
End If
Do While bereich <> ""
If InStr(1, bereich, ",") > 0 Then
nBer = Trim(Left(bereich, InStr(1, bereich, ",") - 1))
bereich = Trim(Right(bereich, Len(bereich) - Len(nBer) - 1))
Set gesBereich = Application.Union(gesBereich, ActiveSheet.Range(nBer))
Else
nBer = bereich
bereich = ""
Set gesBereich = Application.Union(gesBereich, ActiveSheet.Range(nBer))
End If
Loop
'Fehlerprüfung, falls es kein Blatt links des aktiven gibt
If aktNummer = 1 Then
MsgBox "Das erste Blatt ist aktiv, der Vorgang wurde abgebrochen"
Exit Sub
End If
'Zellen markieren
For Each zelle In gesBereich
If ActiveWorkbook.Sheets(aktNummer - 1).Range(zelle.Address).Value = zelle.Value Then
zelle.Interior.Color = farbe
End If
Next
End Sub
Okay, das funktioniert nun soweit! Vielen vielen Dank!
Eine Frage noch:
Ich würde noch ein Makro hinzufügen, der ein Blatt als Vorlage nimmt und ganz rechtseinfügt. Wie kann ich das Blatt denn immer ganz rechts einfügen?
Sub BlattAusVorlage()
' vorher erstelltes Vorlagenblatt einblenden
' Sheets("Parkplatz?bersicht Vorlage").Visible = True
' Vorlagenblatt kopieren
Sheets("Parkplatz?bersicht Vorlage").Copy After:=Sheets(1)
' neues Blatt benennen
Sheets(2).Name = "Bitte Datum erg?nzen"
' Vorlagenblatt wieder ausblenden
' Sheets("Parkplatz?bersicht Vorlage").Visible = False
End Sub
Ah passt, habe es hinbekommen :) "Sheets.Count"
Guten Tag. Ich hätte da nochmal was. Wie kann ich es umsetzten, dass wenn ich eine Zelle (aus einem großen Bereich) nach deren Schriftfarbe überprüfe, sprich ich würde einen Button haben der mir dann folgendes ausgibt:
Gib mir alle Zellen (aus Bereich) aus 'ArbeitsblattXX' mit der Schriftfarbe Grün (Die Schriftfarbe wird mit einer Bedingten Formatierung gesetzt?
Beste Grüße
Guten Tag. Ich hätte da nochmal was. Wie kann ich es umsetzten, dass wenn ich eine Zelle (aus einem großen Bereich) nach deren Schriftfarbe überprüfe, sprich ich würde einen Button haben der mir dann folgendes ausgibt:
Gib mir alle Zellen (aus Bereich) aus 'ArbeitsblattXX' mit der Schriftfarbe Grün (Die Schriftfarbe wird mit einer Bedingten Formatierung gesetzt?
Beste Grüße
Guten Morgen,
am Einfachsten wäre es wenn du in VBA ebenfalls die Bedingung prüfst die in der bedingten Formatierung (BF) die Farbe setzt. Ist das eine Option für dich?
Falls nicht wird es komplizierter, der Farbwert der Zelle bleibt nämlich trotz BF gleich (also vermutlich die 0 des Standard-Schwarz). Daher müsste man theoretisch alle BF der Zelle auslesen und prüfen.
Okay - dann hätte ich noch eines Sache.
Ich habe eine Tabelle über 10 Zeilen und 4 Spalten (A,B,C,D). Pro Zeile (A B C) soll nun nach einen Textanteil ("RD") gesucht werden. Falls dies irgendwo gefunden wird, soll die Zelle aus der Spalte D in eine Liste eingefügt werden.
Dies soll Zeile für Zeile ausgeführt werden.
Es hapert bei der Ausführung :(
Könntest du das weiterhelfen? Besten Dank!
Um zu prüfen ob etwas in einem String vorkommt kann man InStr() nutzen. Das gibt die erste Position einer Zeichenfolge in einer anderen Zeichenfolge aus, kommt sie nicht vor wird 0 ausgegeben. Der Rest ist dann die Zellen einzeln in einer Schleife zu prüfen:
Sub textsuche()
Dim doppelZeile As Boolean
Dim bereich As Range, zelle As Range
Dim sText As String, xList As String
ausblatt = "Tabelle1"
ausbereich = "A1:D4"
sText = "RD"
doppelZeile = False
Set bereich = ActiveWorkbook.Sheets(ausblatt).Range(ausbereich)
For Each zelle In bereich
zeile = zelle.Row
If InStr(1, zelle.Value, sText) > 0 And (trefferzeile <> zeile Or doppelZeile) Then
If xList <> "" Then
xList = xList & ", "
End If
xList = xList & ActiveWorkbook.Sheets(ausblatt).Range("D" & zelle.Row)
trefferzeile = zelle.Row
End If
Next zelle
If xList = "" Then
MsgBox "keine Treffer."
Else
MsgBox xList
End If
End Sub
Hab dir gleich noch eine Bedingung mit eingebaut, mit der du einstellen kannst ob mehrfach-Treffer in derselben Zeile auch mehrfach ausgegeben werden sollen.
Der Suchalgorithmus funktioniert einwandfrei! Danke!
Wenn ich ihn ausführe, kommen die Ergebnisse in einem neuen Fenster. Wie kann ich die Ausgaben in einer Range (zB: B10:B44) ausgeben?
Vielen Dank im Voraus!
Bitte :D
Normalerweise würde ich die Ausgabe dann direkt durchführen, anstatt die Liste zu schreiben. Aber da wir die Liste jetzt schon haben, können wir sie ja auch nutzen:
Sub textsuche()
Dim doppelZeile As Boolean
Dim zeile As Long, treffer As Long, t As Long
Dim bereich As Range, zelle As Range, ausgabeStart As Range
Dim sText As String, xList As String, eintrag As String
ausblatt = "Tabelle1"
ausbereich = "A1:D4"
sText = "RD"
doppelZeile = True
Set ausgabeStart = ActiveWorkbook.Sheets("Tabelle2").Range("B10")
Set bereich = ActiveWorkbook.Sheets(ausblatt).Range(ausbereich)
treffer = 0
For Each zelle In bereich
zeile = zelle.Row
If InStr(1, zelle.Value, sText) > 0 And (trefferzeile <> zeile Or doppelZeile) Then
If xList <> "" Then
xList = xList & ", "
End If
xList = xList & ActiveWorkbook.Sheets(ausblatt).Range("D" & zelle.Row)
trefferzeile = zelle.Row
treffer = treffer + 1
End If
Next zelle
If treffer = 0 Then
MsgBox "keine Treffer."
Else
For t = 1 To treffer
If t < treffer Then
eintrag = Left(xList, InStr(1, xList, ",") - 1)
xList = Trim(Right(xList, Len(xList) - Len(eintrag) - 1))
Else
eintrag = xList
End If
ausgabeStart.Offset(t - 1, 0) = eintrag
Next t
End If
End Sub
Es wird von B10 an zeilenweise ausgegeben, ohne Begrenzung nach unten, oder bestehst du auf einem festen Bereich?
Ich versuche den VBA Code zu verstehen, das klappt aber irgendwie noch nicht ganz.
Was muss ich in der If schleife verändern, wenn ich untersuchen will, wo kein mal "RD" vorkommt?
Also: If includes "RD" -> schreibe in Tabelle
Else -> nichts
Die For zelle -Schleife geht alle Zellen im Bereich zeilenweise durch. Der enthaltene If-Block überprüft ob sie den String "RD" enthalten (und ggfls ob es in der Zeile bereits einen Treffer gab, je nach Einstellung von doppelZeile). Über Else in diesem If-Block könnte man zwar die Zeilen mit Zellen die kein "RD" enthalten finden, allerdings nicht direkt eine Aussage darüber treffen ob die entsprechende Zeile es auch tasächlich 0-mal enthällt.
Um komplett leere Zeilen finden zu können braucht man daher mindestens einen weiteren If-Block, am Einfachsten dürfte es sein, sie am Anfang als leer anzusehen und den Eitnrag bei einem treffer wieder zu entfernen:
Sub textsuche()
Dim doppelZeile As Boolean, ausgabeKeineTreffer As Boolean
Dim zeile As Long, treffer As Long, t As Long, nTreffer As Long, trefferzeile As Long
Dim bereich As Range, zelle As Range, ausgabeStart As Range
Dim sText As String, xList As String, eintrag As String, ausBlatt As String, ausBereich As String, nList As String
ausBlatt = "Tabelle1"
ausBereich = "A1:D5"
sText = "RD"
doppelZeile = True
Set ausgabeStart = ActiveWorkbook.Sheets("Tabelle2").Range("B10")
ausgabeKeineTreffer = True
Set bereich = ActiveWorkbook.Sheets(ausBlatt).Range(ausBereich)
treffer = 0
For Each zelle In bereich
zeile = zelle.Row
'neuer Eintrag beim Beginn einer neuen Zeile im Schleifendurchlauf hinzufügen
If zelle.Column - bereich.Column = 0 Then
If nList <> "" Then
nList = nList & ", "
End If
nList = nList & ActiveWorkbook.Sheets(ausBlatt).Range("D" & zelle.Row)
nTreffer = nTreffer + 1
End If
'bisheriger
If InStr(1, zelle.Value, sText) > 0 And (trefferzeile <> zeile Or doppelZeile) Then
If xList <> "" Then
xList = xList & ", "
End If
xList = xList & ActiveWorkbook.Sheets(ausBlatt).Range("D" & zelle.Row)
trefferzeile = zelle.Row
treffer = treffer + 1
'eintrag aus Liste leerer Zellen entfernen
If InStr(1, nList, ",") = 0 Then
nList = ""
Else
nList = Left(nList, InStr(1, Application.WorksheetFunction.Substitute(nList, ",", "@@@", Len(nList) - Len(Application.WorksheetFunction.Substitute(nList, ",", ""))), "@@@") - 1)
End If
nTreffer = nTreffer - 1
End If
Next zelle
If treffer = 0 Then
MsgBox "keine Treffer."
Else
MsgBox "xList: " & xList & Chr(10) & "nList: " & nList
If ausgabeKeineTreffer Then
xList = nList
treffer = nTreffer
End If
For t = 1 To treffer
If t < treffer Then
eintrag = Left(xList, InStr(1, xList, ",") - 1)
xList = Trim(Right(xList, Len(xList) - Len(eintrag) - 1))
Else
eintrag = xList
End If
ausgabeStart.Offset(t - 1, 0) = eintrag
Next t
End If
End Sub
Wo bzw. wie muss ich die Schleife einfügen, um bei der nList die Leeren Zeilen nicht auszugeben?
Zum Testen hatte ich die Variable "ausgabeKeineTreffer" eingefügt und offenbar vergessen sie wieder auf True zu setzen bevor ich den Code kopiert habe. Abhängig von dieser wird kurz vor der Auflistung die xList mit der nList überschrieben
Else
MsgBox "xList: " & xList & Chr(10) & "nList: " & nList
If ausgabeKeineTreffer Then
xList = nList
treffer = nTreffer
End If
Ich habe mein Frage blöd gestellt.
Ich meinte, wenn RD in einer Zeile nicht gefunden wird, da alle Zellen der Zeile leer sind.
Dann sollte die diese nicht ausgegeben werden bzw als richtig (RD gefunden) angezeigt werden
Jetzt bin ich verwirrt, xList "überspringt" die leeren Zeilen doch bereits? Beispielsweise bei so einer Tabelle würde es "1, 3" ausgeben
- A | B | C | D
- Zeile 1: ARD | B | C | 1
- Zeile 2: | | | 2
- Zeile 3: A | B | RD | 3
Hatte einen Denkfehler. Danke dir, nun passt alles!
Hey du :) ich hätte da noch ein Problem Off-Topic:
ich würde eine Tabelle erstellen wollen, welche man immer links erneuern kann, sprich mit dem Tastenklick auf die Schaltfläche, soll eine neue Spalte (nur von G6:G20) eingefügt werden. Gleichzeitig (bzw. davor) sollen die alten Spalten nach rechts geschoben werden.
Ich habe es versucht, durch ein Bild zu verdeutlichen.
Habe im Internet folgenden Ansatz gefunden. Habe in VBA aber nur schlechte Kenntnisse, weshalb ich den Code nicht auf mein Problem anpassen kann. Könnt ihr mir da helfen?
2. Das Eingefügte (also die Vorlage(Tabellenstriche)) kann ja von irgendwo eingefügt werden: zB: X1000:X1014 - richtig?
Das wäre so was ähnliches, richtig?
Sub aufdroeseln()
Dim Zelle As Range
Columns("C7:C14").Insert Shift:=xlToRight
For Each Zelle In Range("C7:C14" & Range("C65536").End(xlUp).Row)
If Zelle.Font.Bold = True Then
Zelle.Offset(0, 1).Value = Zelle
Zelle.ClearContents
End If
Next
Columns("C7:C14").Font.Bold = False
End Sub
Hi,
hatte deine gestern Frage gesehen, aber die bereits vorhandene Antwort als ausreichend angesehen.
Wenn ich deinen Code grade richtig lese macht er folgendes: zwischen C und D eine neue Spalte einfügen, kopieren aller Zellwerte der alten Spalten C in diese falls deren Schrift fett formatiert ist und leert die alte Spalte C anschließend. Für dein Vorhaben ist das aber unnötig kompliziert, da du ja ohnehin nur das Format übernehmen möchtest.
2 ja theoretisch könnte man es von überall nehmen. Aber da deine Tabelle symetrisch ist, kannst du sie selbst als Vorlage verwenden.
Was genau heißen die beiden Pfeile die von C9 zu C28 gehen? Soll hier eine Kopie der aktuellen Spalte oder eine Kopie der Spalte vor dem kopieren rein? Diese sind jetzt daher noch nicht beachtet:
Sub spalte_einfugen()
Dim lZei As Long
Dim spalte As String
spalte = "G"
lZei = ActiveSheet.Range(spalte & Rows.Count).End(xlUp).Row
Set bereich = ActiveSheet.Range(spalte & 1).EntireColumn
ActiveSheet.Range(spalte & 1).EntireColumn.Insert Shift:=xlShiftToRight
bereich.Copy
bereich.Offset(0, -1).PasteSpecial Paste:=xlPasteFormats
End Sub
Perfekt. Danke dir! Funktioniert soweit.
Aaaaaber: Ich möchte nun die aktuellste Spalte (also immer R8:R19) in eine andere (G8:G19) rüberkopieren.
Sobald ich aber eine neue Spalte einfüge, wird der Code in Spalte G automatisch mitverändert, sprich wird zu (R+1)8:(R+1)19.
Selbst $ hilft nichts. Wie kann die R konstant halten?
Beispieldatei (PNG (musst nach ibb. noch ein Leerzeichen raus machen)): ibb. co/R468ZXh
Bitte :D
Ja, da ist Excel zu intelligent dabei den Bereich anzupassen. (Nebenbei war das ziemlich unerwartet, das es das überhaupt automatisch kann)
Du kannst es entweder im Nachinein per Offset(0, -1) wie in dem Kopiercode zurückschieben oder den Bereichsbezug als String (z.B bereich ="R8:R19") in einer Variable speichern und später über Range(bereich) ansprechen.
Vielen Dank! Das sieht schon mal super aus!
Wie kann ich einen größeren Bereich auswählen? Wird das so funktionieren:
bereich = "I21:I28, I31:I32, I36:I37, I40:I57, I63:I87, I119:I139, I204:I205, I231:I255, I262:I271, I277:I278, Q21:Q28, Q31:Q32, Q63:Q64, Q67:Q84, Q87:Q88; Q231:Q232, Q262:Q271, Q277:Q284"
Leider gibt Excel in der Zeile: "Set markBereich = ActiveSheet.Range(bereich)" einen Fehler aus (Laufzeitfehler 1004)