Microsoft Excel

Herbers Excel/VBA-Archiv

Vergleichen und ergänzen | Herbers Excel-Forum


Betrifft: Vergleichen und ergänzen von: Franz
Geschrieben am: 09.02.2012 08:59:17

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

  

Betrifft: AW: Vergleichen und ergänzen von: Tino
Geschrieben am: 09.02.2012 10:40:11

Hallo,
kannst mal testen.

https://www.herber.de/bbs/user/78819.xls

Gruß Tino


  

Betrifft: AW: Vergleichen und ergänzen von: Franz
Geschrieben am: 09.02.2012 10:50:31

Hallo Tino,

läuft super.

Fehlt jetzt nur noch, dass der Text aus dem Tabellenblatt "Abweichend" der
Spalte 3 in das Tabellenblatt "Original" Spalte D übernommen wird.

Hier erscheint nach Ablauf des Makros Zahlen in Spalte D1=23562, in D3=18642 und in D9=42663.

Gruß
Franz


  

Betrifft: AW: Vergleichen und ergänzen von: Franz
Geschrieben am: 09.02.2012 11:31:12

Hallo Tino,

habe das Problem gefunden.

rngTmp.Offset(, 3).Value = rngAb.Cells(n, 3)

Habe geändert wie folgt und jetzt läuft.

rngTmp.Offset(, 3).Value = rngAb.Cells(n, 4)



Vielen Dank für Deine Mühe.
Hilft mir wirklich bei 89.000 Datensätzen.

Schönen Tag noch.

Gruß
Franz


  

Betrifft: AW: Vergleichen und ergänzen von: Franz
Geschrieben am: 09.02.2012 13:38:23

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



  

Betrifft: AW: Vergleichen und ergänzen von: Tino
Geschrieben am: 09.02.2012 22:48:04

Hallo,
versuche es mal mit diesem Code.
Der falsche Wert im 1. Code war weil die Spalte C ausgeblendet war, darauf habe ich nicht geachtet.

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
Gruß Tino


  

Betrifft: AW: Vergleichen und ergänzen von: Franz
Geschrieben am: 10.02.2012 09:25:24

Vielen Dank Tino.

Ein schönes Wochenende
Franz


Beiträge aus den Excel-Beispielen zum Thema "Vergleichen und ergänzen"