Vergleichen und ergänzen

Liebe Excelfachfrauen und Excelfachmänner,
hätte ein Anliegen wie folgt:
Es gibt ein Arbeitsblatt mit 2 Tabellenblätter mit Namen -Original- und -Abweichend-. -Original- hat 3 Spalten ohne Überschrift. Spalte A beinhaltet Zuordnungsnummer. Spalte B eine dazugehörende Bezeichnung. Spalte C eine sontige Angabe. Tabellenblatt mit Namen -Abweichend- beinhaltet 3 Spalten mit Überschrift Nr, Text, Text2. Mein Anliegen wäre folgende über ein Automatismus: Wenn die Bezeichnung in Spalte A bei Tabelle -Abweichend- und Tabelle -Original- identisch sind soll in Tabellenblatt -Original- die Zeile (Spalte A bis B) grau hinterlegt werden und in Spalte D der Text aus Tabellenblatt -Abweichend- geschrieben werden. Schwierigkeit wäre, dass bei den Einträgen des Tabellenblattes -Original- nur die berücksichtigt werden sollen, die eine schwarze Textfarbe haben.
Ein Beispiel habe ich angefügt.
https://www.herber.de/bbs/user/78815.xls
Liebe Grüße
Franz

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Tino,
wie bekommt man es hin, von dem Tabellenblatt "Abweichend" beide Spalten C und D
in das Tabellenblatt "Original" der "Gefundenen" zu bekommen?
Sollten dann im "Original" in Spalte D und E stehen.
Gruß
Franz
Option Explicit

Sub Text_Zuordnen()
Dim rngOrg As Range, rngAb As Range, rngTmp As Range
Dim n&
With Tabelle1 'Tabelle Orginal, evtl. anpassen
Set rngOrg = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 3)
End With
With Tabelle2 'Tabelle Abweichend, evtl. anpassen
Set rngAb = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 3)
End With
With Application
.ScreenUpdating = False
.EnableEvents = False
For n = 1 To rngAb.Rows.Count
Set rngTmp = Find_Zellen(rngOrg.Columns(1), rngAb.Cells(n, 1))
If Not rngTmp Is Nothing Then
'        rngTmp.Offset(, 3).Value = rngAb.Cells(n, 3)
rngTmp.Offset(, 3).Value = rngAb.Cells(n, 4)
For Each rngTmp In rngTmp.Cells
rngTmp.Resize(, 3).Interior.ColorIndex = 15
Next
End If
Next n
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

Function Find_Zellen(rngBereich As Range, strSuchWert$) As Range
Dim rngFund As Range, strErste$, rngUnion As Range
Set rngFund = rngBereich.Find(What:=strSuchWert, LookIn:=xlValues, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If rngFund Is Nothing Then Exit Function
strErste = rngFund.Address
Do
If rngFund.Font.ColorIndex = 1 Then
If rngUnion Is Nothing Then
Set rngUnion = rngFund
Else
Set rngUnion = Union(rngUnion, rngFund)
End If
End If
Set rngFund = rngBereich.FindNext(rngFund)
Loop While rngFund.Address  strErste
Set Find_Zellen = rngUnion
End Function

Option Explicit Sub Text_Zuordnen() Dim rngOrg As Range, rngAb As Range, rngTmp As Range Dim n& With Tabelle1 'Tabelle Orginal, evtl. anpassen Set rngOrg = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 5) End With With Tabelle2 'Tabelle Abweichend, evtl. anpassen Set rngAb = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 5) End With With Application .ScreenUpdating = False .EnableEvents = False For n = 1 To rngAb.Rows.Count Set rngTmp = Find_Zellen(rngOrg.Columns(1), rngAb.Cells(n, 1)) If Not rngTmp Is Nothing Then rngTmp.Offset(, 3).Resize(, 2).Value = rngAb.Cells(n, 4).Resize(, 2).Value For Each rngTmp In rngTmp.Cells rngTmp.Resize(, 5).Interior.ColorIndex = 15 Next End If Next n .EnableEvents = True .ScreenUpdating = True End With End Sub Function Find_Zellen(rngBereich As Range, strSuchWert$) As Range Dim rngFund As Range, strErste$, rngUnion As Range Set rngFund = rngBereich.Find(What:=strSuchWert, LookIn:=xlValues, LookAt _ :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _ False, SearchFormat:=False) If rngFund Is Nothing Then Exit Function strErste = rngFund.Address Do If rngFund.Font.ColorIndex = 1 Then If rngUnion Is Nothing Then Set rngUnion = rngFund Else Set rngUnion = Union(rngUnion, rngFund) End If End If Set rngFund = rngBereich.FindNext(rngFund) Loop While rngFund.Address <> strErste Set Find_Zellen = rngUnion End Function

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Vergleichen und ergänzen

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread