Transponieren

[sundw1]

Hallo

ich möchte Zellen mit einen bestimmten Text Transponieren. Mit der ganzen Zeile oder einzelnen Zellen klappt es. Es sind aber (schon sortiert) mehrere Zellen mit gleichen Inhalt. Wie kann ich die nebeneinder liegenden Zellen zum Transponieren markieren ?

Für einen Tip schon mal Danke
---------------------------------------------------------------------

Code:

Sub Makro2()
Dim zeLLe As Range, Bereich As Range

    Cells.Find(What:="ab", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    Selection.Copy
    ActiveCell.Offset(0, -21).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

   Cells.Find(What:="yz", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    Selection.Copy
    ActiveCell.Offset(0, -21).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    
End Sub

Code strukturiert dargestellt durch 3. Button von rechts im Beitragsformular: #
photo Raute_zps3ee56209.jpg
[Bild: smilie.php?smile_ID=1810]

[atilla]

Hallo,

stell bitte eine Beispieltabelle ein.
Man sollte vorher und nachher ersehen können.

[sundw1]

Hallo,

die Zellen mit gleichen Inhalt sollen transponiert werden.
Tabelle1

A

B

C

D

E

F

G

H

I

J

K

L

M

N

1

2

ab

yz

ab

ab

ab

yz

yz

yz

yz

3

ab

yz

4

ab

yz

5

yz

6

7

vorher

8

9

10

Wunsch

11

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4.8

[atilla]

Hallo,

leider sind das zu dürftige Angaben. Ich gehe auch davon aus, dass Die Daten bei Dir an anderer Stelle stehen. Da Du im Code mit Activecell arbeitest, kann auch aus dem Code heraus nicht abgeleitet werden, wo sie stehen und wo sie hinkopiert werden sollen.

Deswegen habe ich Deinen Code genommen und ohne jede Fehlerabfragen die Fundstellen in A1 und C1 transponiert.

Code:

Option Explicit

Sub Makro2()
   Dim zeLLe As Range, Bereich As Range
   Dim Anzahl As Long
   Set zeLLe = Cells.Find(What:="ab", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False)
   Anzahl = Application.CountIf(Rows(zeLLe.Row), zeLLe) - 1
   Set Bereich = Range(Cells(zeLLe.Row, zeLLe.Column), Cells(zeLLe.Row, zeLLe.Column + Anzahl))
    Bereich.Copy
    Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

   Set zeLLe = Cells.Find(What:="yz", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False)
   Anzahl = Application.CountIf(Rows(zeLLe.Row), zeLLe) - 1
   Set Bereich = Range(Cells(zeLLe.Row, zeLLe.Column), Cells(zeLLe.Row, zeLLe.Column + Anzahl))
   Bereich.Copy
   Range("C1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
      False, Transpose:=True
End Sub

[sundw1]

Hallo Atilla,

genau, das ist die Lösung. Vielen Dank.

[sundw1]

Hallo Atilla,

leider war meine Freude zu früh. Wenn ich F2 aktiviere und dann Makro ausführe alles ok.
Wenn ich F7 aktiviere und Makro ausführe dann werden die Zellen mit ("ab")aus Zeile 7 richtig übernommen,
aber auch die Zellen aus Zeile 2 (yz). Es soll nur die Zeile welche aktiviert ist bearbeitet werden.

Tabelle1

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

1

A

B

C

D

E

F

G

H

I

J

K

L

M

N

2

1

3

2

ab

yz

ab

ab

ab

yz

yz

yz

yz

4

3

ab

yz

5

4

ab

yz

6

5

yz

7

6

8

7

ab

ab

vorher

9

8

10

9

11

10

Wunsch

12

11

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4.8

[Rabe]

Hi,

Es soll nur die Zeile welche aktiviert ist bearbeitet werden.

für eine korrekte Lösung ist es vorteilhaft, die Aufgabe gleich am Anfang komplett zu stellen.

[atilla]

Hallo,

ich hatte mich schon gewundert, dass da keine Fortsetzung kommt.
Und es gibt immer nur "ab" und "yz" in der Zeile?
Kommen immer beide Suchbegriffe vor oder kann eines oder keins vorhanden sein?

Mit den dürftigen Angaben kann man leider nur eine dürftige Lösung vorschlagen.
Unten der Code hat jetzt einige Einschränkungen.
Es wird immer ab Spalte 6 in der aktiven Zeile nach den zwei benannten Werten gesucht.
Bei Fund wird der Erste in Spalte A ab der aktiven Zeile und der Zweite in C ab der aktiven Zeile transponiert.

Code:

Sub Makro2()
   Dim lngZ As Long, lngs As Long
   lngZ = ActiveCell.Row
   lngs = 6
   Dim zeLLe As Range, Bereich As Range
   Dim Anzahl As Long
   Set zeLLe = Range(Cells(lngZ, lngs), Cells(lngs, Columns.Count)).Find(What:="ab", After:=Range("F" & lngs), LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False)
   If Not zeLLe Is Nothing Then
      Anzahl = Application.CountIf(Range(Cells(lngZ, lngs), Cells(lngs, Columns.Count)), zeLLe) - 1
      Range(Cells(zeLLe.Row, zeLLe.Column), Cells(zeLLe.Row, zeLLe.Column + Anzahl)).Copy
       Range("A" & lngZ).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
           False, Transpose:=True
          
   End If
  
   Set zeLLe = Range(Cells(lngZ, lngs), Cells(lngs, Columns.Count)).Find(What:="yz", After:=Range("F" & lngs), LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False)
   If Not zeLLe Is Nothing Then
      Anzahl = Application.CountIf(Range(Cells(lngZ, lngs), Cells(lngs, Columns.Count)), zeLLe) - 1
      Range(Cells(zeLLe.Row, zeLLe.Column), Cells(zeLLe.Row, zeLLe.Column + Anzahl)).Copy
       Range("C" & lngZ).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
           False, Transpose:=True
      Set zeLLe = Nothing
   End If
End Sub

So einen Code kann man dann z.B mit Doppelklick in eine Zelle starten.

Den obigen Code und folgenden einfach in das Code Modul der Tabelle einfügen:

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   Call Makro2
   Cancel = True
End Sub

[sundw1]

Hallo Atilla,

da kommt ein alter Mann aus dem Staunen nicht mehr raus.

Vielen Dank, jetzt klappt es