markierte Zellen aus einer Spalte nebeneinander "transportieren"

[Johannes]

Hallo zusammen,

habe Daten, die folgendermaßen aussehen:

[
Bild bitte so als Datei hochladen: Klick mich!
]

diese sollen nebeneinander dargestellt werden:

[
Bild bitte so als Datei hochladen: Klick mich!
]

Hat jemand eine Idee, wie man diesen Prozess automatisieren kann?

Vielen Dank und beste Grüße
Johannes

[Gast 123]

Hallo Johannes,

dieses Makro bitte in ein Modulblatt kopieren und laufen lassen. Ich habe in der Const die Startadr auf "B6" gesetzt.
Wenn andere Bereiche kopiert werden müssen brauchst du nur diese StartAdr zu aendern. Mein Programm sucht immer den Block, der durch eine Leerzeile abgegrenzt ist, Wieviele Blöcke es sind spielt keine Rolle. Denke aber bitte daran das die Spalten rechts von "B" frei sein müssen. Sonst würden diese Daten überschrieben. Das prüfe ich nicht nach!! Ich hoffe die Aufgabe ist damit gelöst.

mfg  Gast 123

Code:

Option Explicit     '19.8.2016  Gast 123  Clever Forum

Const StartAdr = "B6"  'Start Adresse selbst einsetzen


Sub Zellen_inSpalte_transponieren()
Dim sp As Integer, lz As Integer
Dim AnfAdr As String, EndAdr As String
   
   'LastZell in Spalte B ermitteln
   lz = Cells(Rows.Count, "B").End(xlUp).Row
   '1. Cut Adresse in Saplte B ermitteln
   AnfAdr = Range(StartAdr).End(xlDown).End(xlDown).Address

   Do 'Loop Schleife zum ausschneiden und einfügen
      sp = sp + 1   'Spalten transponieren
      EndAdr = Range(AnfAdr).End(xlDown).Address
      Range(AnfAdr, EndAdr).Cut Destination:= _
      Range(StartAdr).Offset(0, sp)
      Application.CutCopyMode = False
      AnfAdr = Range(EndAdr).End(xlDown).Address
   Loop Until Range(AnfAdr).End(xlDown).Row > lz
End Sub

[RPP63]

Moin!
Wenn ich den Threadtitel auf die Goldwaage lege:

Sub RPP()
Dim i As Byte
For i = 2 To Selection.Areas.Count
   Selection.Areas(i).Cut Cells(6, 2).Offset(, i - 1)
Next
End Sub

Natürlich ist aber die Lösung von Gast 123 sinnvoller, weil nicht erst markiert werden muss.

Gruß Ralf

[Fennek]

Hallo,

ein anderer Vorschlag:

Code:

Sub iBlock()
Dim ar As Range
For Each ar In Columns(2).SpecialCells(2).Areas
   i = i + 1
   ar.Copy Range("B6").Offset(, i)
Next ar
End Sub

Die Adressierung ist sehr speziell für diesen Fall, aber wenn Range("B6") über eine Variable gesetzt wird, ginge es auch etwas allgemeiner.

mfg

[Johannes]

Sehr geil!!! Vielen Dank!