Unikate aus Zellen in Spalten kopieren

[tmessers]

Hallo liebes Forum,

ich habe folgendes Problem:

ich möchte 1) die Spalte A durchsuchen. Die Zeilen in Spalte A sind mit einzelnen Worten befüllt.
Dabei handelt es sich um wieder gleichen Worte.
Ich suche einen Code, der die Spalte A nach diesen Worten durchsucht aber immer nur einmal
berücksichtigt.
Ich glaube ich habe dazu mit .Advanced Filter ...Unique:=True ein brauchbares Instrument gefunden.
.AdvancedFilter enthält ja schon die Möglichkeit zu kopieren aber zweitens möchte ich die gefundenen Worte
in einem anderen Tabellenblatt als Spaltenüberschrift nutzen.
Dazu würde ich .SpecialPaste ...,Transponse:=True nutzen.

Ich weiß aber leider nicht wie ich .AdvancedFilter mit . SpecialPaste kombinieren kann.

Kann mit jemand helfen?

Gruß

tmessers

[Kuwer]

Hallo,

so in der Art:

Sub Makro1()

  Dim wsQ As Worksheet, wsZ As Worksheet

  Set wsQ = Worksheets("Tabelle1")

  Set wsZ = Worksheets("Tabelle2")

  With wsQ.Range("A1").CurrentRegion.Columns(1)

    .AdvancedFilter Action:=xlFilterInPlace, Unique:=True

    .Offset(1).Resize(.Rows.Count - 1).Copy

  End With

  wsZ.Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _

                               SkipBlanks:=False, Transpose:=True

  wsQ.ShowAllData

End Sub

Gruß Uwe

[Gast 123]

Hallo

mal auf die schnelle ein Makro, das die Aufgabe lösen kann.  Bitte in ein Modulblatt kopieren und die Namen der Tabellen noch prüfen, ggf. in der Const Anweisung aendern.  Zum Testen steht dort "Tabelle 1 + 2".  Ich sortiere die Überschrift aber nicht!

mfg  Gast 123

Code:

Option Explicit      '6.2.2017  Gast 123  Clever Forum

Const Tab1 = "Tabelle1"   'Name der Quell Tabelle eintragen
Const Tab2 = "Tabelle2"   'Name der Ziel Tabelle eintragen


Sub SpaltenÜberschrift_ausfüllen()
Dim AC As Object, Spa As Integer
Dim TB1 As Worksheet, rFind As Object
Dim TB2 As Worksheet, EndAdr As String
Set TB1 = Worksheets(Tab1)
Set TB2 = Worksheets(Tab2)

'End-Adresse in Spalte "A" Tabelle1
EndAdr = TB1.Cells(Rows.Count, 1).End(xlUp).Address
Spa = 1  '1.Spalte in Tabelle2 als Spalten-Überschrift

'Schleife für alle Namen in Spalte "A"
For Each AC In TB1.Range("A1", EndAdr)
  If AC.Value <> Empty Then
  'Prüfen ob Namen in Tabelle2 bereits vorkommt
  Set rFind = TB2.Range("A1").Resize(1, Spa + 1).Find(What:=AC, After:= _
      Range("A1"), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
  'Wenn "Nein" Überschrift setzen
  If rFind Is Nothing Then
     TB2.Range("A1").Cells(1, Spa) = AC.Value
     Spa = Spa + 1
  End If
  End If
Next AC
End Sub

[tmessers]

@Uwe

DAnke wieder einmal für Deine Hilfe.
Der Code funktioniert wieder wunderbar!!


@Gast123
Dir auch danke. Auch der Code führt zum gewünschten Ergebnis.

[snb]

Code:

Sub M_snb()
   Sheet1.Columns(1).AdvancedFilter 2, , Sheet2.Cells(1), -1
   Sheet2.Cells(1).Resize(, Sheet2.Cells(1).CurrentRegion.Rows.Count) = Application.Transpose(Sheet2.Cells(1).CurrentRegion)
   Sheet2.Columns(1).Delete
End Sub