Vergleichen in 2 Tabellenblättern und dann einfärb

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub machen() Dim o As Object, k As Variant Dim a Dim z&, zmax& With Sheets("Gesamt Material") zmax = .Range("A" & .Rows.Count).End(xlUp).Row a = .Range("A1:A" & zmax) End With Set o = CreateObject("scripting.dictionary") For z = 17 To zmax If Len(a(z, 1)) > 1 Then o(a(z, 1)) = o(a(z, 1)) + 1 Next z = 0 If o.Count > 0 Then With Sheets("Freie Nummern") For Each k In o.keys If o(k) > 1 Then z = z + 1 .Cells(Mid(k, 2) + 3, Mid(k, 1, 1)).Interior.Color = vbRed End If Next End With MsgBox o.Count & " Einträge, davon " & z & " Doppelte" End If End Sub

Option Explicit Sub ur() Dim r As Range Set r = ActiveSheet.UsedRange MsgBox "activeSheet.UsedRange.Rows.Count " & _ ActiveSheet.UsedRange.Rows.Count & _ vbLf & "activeSheet.UsedRange.columns.Count " _ & ActiveSheet.UsedRange.Columns.Count & vbLf & _ "activeSheet.UsedRange(0).address bzw. r(0) " & _ r(0).Address ' usedrange(0) geht nicht End Sub

Sub ur2() MsgBox "activeSheet.UsedRange.Rows.Count " & _ ActiveSheet.UsedRange.Rows.Count & _ vbLf & "activeSheet.UsedRange.columns.Count " _ & ActiveSheet.UsedRange.Columns.Count & vbLf & _ "Split(ActiveSheet.UsedRange.Address,...)(0) " & _ Split(ActiveSheet.UsedRange.Address, ":")(0) End Sub

Hallo Danny,
zwar hat Michael einmal mehr eine Lösung geliefert, und ich hoffe Du bist nicht böse, dass ich mich einmische Michael. Ich möchte meine Lösung nämlich aus nostalgischen Gründen trotzdem präsentieren. Bei mir musst Du zwar keine Spalte verschieben, aber das Ganze läuft dafür (auf meiner AMD Kaveri Maschine) ca. 1 Minute, bis es fertig ist.
Die nostalgischen Anwandlungen rühren daher, dass eine ähnliche Aufgabenstellung mein Einstieg in Excel VBA war. 2006 arbeitete ich als Freelancer in einem von zwei Teams, die Fotoaufnamen von Mitarbeitern eines Unternehmens für neue Konzernausweise machten. Am Ende eines Tages setzten sich zwei Leute aus beiden Teams zusammen und glichen die Listen von Hand ab. Welches Team hat wen Fotografiert. Ich dachte ich guck nicht richtig, steuerte nach Feierabend die nächste Buchhandlung an und kaufte mir mein erstes Buch zu Excel VBA. Eine Woche später präsentietre ich den beiden Teams eine Lösung, die die beiden Tageslisten automatisch abgleicht. (Fast 9.000 Personaldatensätze)
Wichtig war mir bei der Entwicklung meines Makros, dass genau so vorgegangen wurde, wie alle Team-Kollegen es kannten. Es wurde mit Hintergrundfarben gearbeitet, um bereits fotografierte Mitarbeiter zu markieren. Ich fand das alles wahnsinnig kompliziert, wollte aber unbedingt die Automatik, ohne den Kollegen gegenüber überheblich zu erscheinen. Es ging ja nur darum etwas zu vereinfachen, damit alle früher Feierabend haben.
Das hat super funktioniert. Alle waren zufrieden :-)
Hier mein Färbelösung für Dein Problem:


Option Explicit
Sub ZellenFaerben()
Dim i As Long
Dim j As Long
Dim k As Long
Dim strQuellTabelle As String
Dim strZielTabelle As String
Dim lQuellTabelleZeilen As Long
Dim lZielTabelleZeilen As Long
Dim lZielTabelleSpalten As Integer
Dim lStartZeileQuellTabelle As Byte
Dim lStartZeileZielTabelle As Byte
Dim lDoppelteFarbeRotAnteil As Long
Dim lDoppelteFarbeGruenAnteil As Long
Dim lDoppelteFarbeBlauAnteil As Long
Dim bolTreffer As Boolean
strQuellTabelle = "Gesamt Material"
strZielTabelle = "Freie Nummern"
lQuellTabelleZeilen = Sheets(strQuellTabelle).UsedRange.Rows.Count
lZielTabelleZeilen = Sheets(strZielTabelle).UsedRange.Rows.Count
lZielTabelleSpalten = Sheets(strZielTabelle).UsedRange.Columns.Count
lStartZeileQuellTabelle = 17
lStartZeileZielTabelle = 4
lDoppelteFarbeRotAnteil = 255
lDoppelteFarbeGruenAnteil = 0
lDoppelteFarbeBlauAnteil = 0
For i = lStartZeileQuellTabelle To lQuellTabelleZeilen
bolTreffer = False
If Sheets(strQuellTabelle).Cells(i, 1).Value  "" Then
For j = lStartZeileZielTabelle To lZielTabelleZeilen
For k = 1 To lZielTabelleSpalten
If Sheets(strQuellTabelle).Cells(i, 1).Value = Sheets(strZielTabelle). _
Cells(j, k).Value Then
Sheets(strZielTabelle).Cells(j, k).Interior.Color = RGB( _
lDoppelteFarbeRotAnteil, _
lDoppelteFarbeGruenAnteil, _
lDoppelteFarbeBlauAnteil)
bolTreffer = True
Exit For
End If
If bolTreffer = True Then
Exit For
End If
Next k
Next j
End If
Next i
End Sub

Viele Grüße,
Zwenn

Option Explicit Sub ZellenFaerben() Dim i As Long Dim j As Long Dim k As Long Dim strQuellTabelle As String Dim strZielTabelle As String Dim lQuellTabelleZeilen As Long Dim lZielTabelleZeilen As Long Dim lZielTabelleSpalten As Integer Dim lStartZeileQuellTabelle As Byte Dim lStartZeileZielTabelle As Byte Dim lDoppelteFarbeRotAnteil As Long Dim lDoppelteFarbeGruenAnteil As Long Dim lDoppelteFarbeBlauAnteil As Long Dim bolTreffer As Boolean strQuellTabelle = "Gesamt Material" strZielTabelle = "Freie Nummern" lQuellTabelleZeilen = Sheets(strQuellTabelle).UsedRange.Rows.Count lZielTabelleZeilen = Sheets(strZielTabelle).UsedRange.Rows.Count lZielTabelleSpalten = Sheets(strZielTabelle).UsedRange.Columns.Count lStartZeileQuellTabelle = 17 lStartZeileZielTabelle = 4 lDoppelteFarbeRotAnteil = 255 lDoppelteFarbeGruenAnteil = 0 lDoppelteFarbeBlauAnteil = 0 For i = lStartZeileQuellTabelle To lQuellTabelleZeilen bolTreffer = False If Sheets(strQuellTabelle).Cells(i, 1).Value "" Then For j = lStartZeileZielTabelle To lZielTabelleZeilen For k = 1 To lZielTabelleSpalten If Sheets(strQuellTabelle).Cells(i, 1).Value = Sheets(strZielTabelle). _ Cells(j, k).Value Then Sheets(strZielTabelle).Cells(j, k).Interior.Color = RGB( _ lDoppelteFarbeRotAnteil, _ lDoppelteFarbeGruenAnteil, _ lDoppelteFarbeBlauAnteil) bolTreffer = True Exit For End If Next k If bolTreffer = True Then Exit For End If Next j End If Next i End Sub

Beliebteste Forumthreads (12 Monate)

Vergleichen in 2 Tabellenblättern und dann einfärb

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Vergleichen in 2 Tabellenblättern und dann einfärb

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

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread