Clever-Excel-Forum

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

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

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

@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.

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

tmessers

Kuwer

Gast 123

tmessers

snb