Thema Datum  Von Nutzer Rating
Antwort
15.04.2016 16:53:15 Alex
NotSolved
Blau So was?
 15.04.2016 19:27:42 Gast70117
NotSolved
19.04.2016 12:14:54 Alex
NotSolved

Ansicht des Beitrags:
Von:
Gast70117		 Datum:
15.04.2016 19:27:42		 Views:
460		 Rating:
     
Antwort:
  Ja
Thema:
So was?		 
Option Explicit

Sub Schiffefinden()
'Vereinbarung Quelltabelle = "Tabelle1", Zieltabelle = "Tabelle2" - Tabellen sind vorhanden

Dim c As Range, x As Long
Dim fnd As Range, fa As String

'Zieltabelle löschen
Sheets("Tabelle2").UsedRange.Clear

'Quelltabelle durchlaufen
For Each c In Sheets("Tabelle1").UsedRange
   If c.Value <> "" Then
      x = x + 1
      c.Copy Sheets("Tabelle2").Cells(x, 1)
   End If
Next c

'Zieltabelle eindeutige Werte
With Sheets("Tabelle2")
   Set c = .UsedRange
   c.RemoveDuplicates Columns:=1, Header:=xlNo
   Set c = .UsedRange
   With .Sort
      .SortFields.Clear
      .SortFields.Add Key:=Range(c.Address)
      .SetRange Range(c.Address)
      .Header = xlGuess
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
   End With
   'mit diesen Werten suchen
   For Each c In .UsedRange
      With Sheets("Tabelle1").UsedRange
         x = 0
         Set fnd = .Find(c.Value)
         If Not fnd Is Nothing Then
            fa = fnd.Address
            'Treffer auftragen
            Do
               x = x + 1
               c.Offset(, x).Value = c.Value & Chr(32) & fnd.Address(0, 0)
               Set fnd = .FindNext(fnd)
            Loop While Not fnd Is Nothing And fnd.Address <> fa
         End If
      End With
   Next c
   'Spalte 1 löschen
   Columns(1).Delete Shift:=xlToLeft
End With

End Sub

 

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
15.04.2016 16:53:15 Alex
NotSolved
Blau So was?
 15.04.2016 19:27:42 Gast70117
NotSolved
19.04.2016 12:14:54 Alex
NotSolved