Thema Datum  Von Nutzer Rating
Antwort
29.07.2015 08:10:23 Klaus
NotSolved
Blau Zwei Zellen durchsuchen und Wert 3 ausgeben
29.07.2015 15:21:01 Gast24756
NotSolved
30.07.2015 07:15:37 Klaus
NotSolved
31.07.2015 16:41:59 Gast55102
NotSolved
31.07.2015 16:43:22 Gast54893
NotSolved

Ansicht des Beitrags:
Von:
Gast24756
Datum:
29.07.2015 15:21:01
Views:
843
Rating: Antwort:
  Ja
Thema:
Zwei Zellen durchsuchen und Wert 3 ausgeben

Gibt verschiedene Möglichkeiten das zu lösen, hier ist eine:

Option Explicit

Sub Bsp()
  
  Dim rngT1 As Excel.Range
  Dim rngT1H As Excel.Range
  Dim rngT2 As Excel.Range
  Dim rngT2H As Excel.Range
  Dim rngCell As Excel.Range
  Dim rngResult As Excel.Range
  Dim strAddr As String
  
  Set rngT1 = Worksheets("Tabelle1").UsedRange
  Set rngT2 = Worksheets("Tabelle2").UsedRange
  
  'eine (Hilfs-)Spalte einfügen (Tabellenbereich wird nach rechts verschoben)
  Call rngT1.Columns(1).Insert(xlShiftToRight)
  'eine (Hilfs-)Spalte einfügen (Tabellenbereich wird nach rechts verschoben)
  Call rngT2.Columns(1).Insert(xlShiftToRight)
  
  'die (Hilfs-)Spalte referenziern
  Set rngT1H = rngT1.Columns(1).Offset(, -1)
  Set rngT2H = rngT2.Columns(1).Offset(, -1)
  
  'die zwei Spalten rechst von der Hilfsspalte miteinander verketten
  rngT1H.FormulaR1C1 = "=CONCATENATE(""'"",RC[1],""'"",""-"",""'"",RC[2],""'"")"
  rngT2H.FormulaR1C1 = "=CONCATENATE(""'"",RC[1],""'"",""-"",""'"",RC[2],""'"")"
  
  'jede Zeile in Tabelle2 abarbeiten
  For Each rngCell In rngT2H.Cells
    
    'Wert aus (Hilfs-)Spalte Tabelle2 in (Hilfs-)Spalte Tabelle1 suchen
    Set rngResult = rngT1H.Find(rngCell.Value, , LookIn:=xlValues, LookAt:=xlWhole)
    
    If Not rngResult Is Nothing Then
      strAddr = rngResult.Address 'Zelladdr. des 1. Treffers merken
      Do
        'ggf. neue Zeile einfügen
        If Not IsEmpty(rngT2.Cells(rngCell.Row, 3).Value) Then
          Call rngT2.Rows(rngCell.Row).EntireRow.Offset(1).Insert(xlShiftDown)
          'Wert übernehmen
          rngT2.Cells(rngCell.Row + 1, 3).Value = rngResult.Offset(, 3).Value
        Else
          'Wert übernehmen
          rngT2.Cells(rngCell.Row, 3).Value = rngResult.Offset(, 3).Value
        End If
        'nach weiteren Treffern in Tabelle1 suchen
        Set rngResult = rngT1H.FindNext(After:=rngResult)
      Loop While rngResult.Address <> strAddr 'solange bis keine >neue< Zelle mehr gefunden wird
    End If
    
  Next
  
  '(Hilfs-)Spalten löschen
  Call rngT1H.Delete(xlShiftToLeft)
  Call rngT2H.Delete(xlShiftToLeft)
  
End Sub

Tabelle2 sieht am Ende so aus:

Klaus Schulze Doppelkopf
    Skat
Peter Thona Rommê
Ingo Schmidt Doppelkopf

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
29.07.2015 08:10:23 Klaus
NotSolved
Blau Zwei Zellen durchsuchen und Wert 3 ausgeben
29.07.2015 15:21:01 Gast24756
NotSolved
30.07.2015 07:15:37 Klaus
NotSolved
31.07.2015 16:41:59 Gast55102
NotSolved
31.07.2015 16:43:22 Gast54893
NotSolved