Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Spaltenwert in Zeilen verschieben

Spaltenwert in Zeilen verschieben
23.05.2017 15:47:11
Tobias
Hallo,
meine Tabelle hat ausschließlich Daten in Spalte A, und davon sehr viele alle untereinander. Jetzt möchte ich für eine Seriendruckfunktion jeweils 5 Einträge aus der Spalte in eine Zeile verschieben und die 4 darunter befindlichen dann leeren Zeilen löschen. Also A1 bleibt, A2 wird B1, A3 wird C1, A4 wird D1 und A5 wird E1, A6 wird A2, A7 wird B2, A8 wird C2 usw.
Kann mir hier jemand mit einem kleinen Makro auf die Sprünge helfen?

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Spaltenwert in Zeilen verschieben
23.05.2017 16:05:17
Jürgen
Hallo Tobias,
wozu hier ein Makro?
Einfach
=INDEX($A:$A;(5*(ZEILE(B1)-1)+SPALTE(B1)-1))

in Zelle B1 eintrage und dann in den Bereich B1 - E99999 kopieren.
alternativ:
=INDEX($A:$A;(5*(SPALTE(B1)-1)+ZEILE(B1)))
in den Bereich B1 - xyz5 kopieren. Dann steht B1=A1,B2=A2, b3=A3...,C1= A6
Gruß
Jürgen
AW: Spaltenwert in Zeilen verschieben
23.05.2017 16:21:31
UweD
Hallo
so?
Sub Eins_in_fuenf()
    On Error GoTo Fehler
    Dim TB, i%
    Dim SP%, ZE&, LR&
    
    Set TB = Sheets("Tabelle1")
    
    SP = 1 'Spalte A 
    ZE = 1 'ab Zeile wegen ggf Überschrift 
    With TB
        LR = .Cells(.Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte 
        For i = ZE To LR Step 5
            .Range(.Cells(i, SP + 1), .Cells(i, SP + 4)) = _
                WorksheetFunction.Transpose(.Range(.Cells(i + 1, SP), .Cells(i + 4, SP)))
            .Range(.Cells(i + 1, SP), .Cells(i + 4, SP)).ClearContents
        Next
    End With
    
    Err.Clear
Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear
End Sub

LG UweD
Anzeige
AW: Spaltenwert in Zeilen verschieben
23.05.2017 17:51:35
Tobias
Hallo Uwe,
vielen Dank für das Makro, es funktioniert, hat nur einen Haken, es löscht nicht die leeren Zeilen, sondern nur deren Inhalt, so dass ich am Ende eine gefüllte und 4 leere Zeilen im Wechsel habe. Kann man das um die Löschfunktion der leeren Zeilen erweitern?
Viele Grüße, Tobias
AW: Spaltenwert in Zeilen verschieben
24.05.2017 08:29:19
UweD
Hallo nochmal
ok, hatte ich anders verstanden.
Dann so...
Hab es noch was gekürzt.
Sub Eins_in_fuenf()
    On Error GoTo Fehler
    Dim TB, SP As Integer, ZE As Double
    Set TB = Sheets("Tabelle1")
    SP = 1 'Spalte A 
    ZE = 1 'ab Zeile wegen ggf Überschrift 
    
    Application.ScreenUpdating = False
    With TB
        Do Until .Cells(ZE + 1, SP) = ""
            .Cells(ZE, SP + 1).Resize(1, 4) = _
                WorksheetFunction.Transpose(.Cells(ZE + 1, SP).Resize(4, 1))
            .Rows(ZE + 1).Resize(4, 1).Delete xlUp
            ZE = ZE + 1
        Loop
    End With
    
    Err.Clear
Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear
End Sub

LG UweD
Anzeige
AW: Spaltenwert in Zeilen verschieben
24.05.2017 11:12:47
Tobias
Sehr genial, Uwe vielen, vielen Dank, das hat mir richtig geholfen, astrein...
Viele Grüße, Tobias
AW: gern geschehen owt
24.05.2017 11:46:19
UweD
AW: Spaltenwert in Zeilen verschieben
23.05.2017 16:36:00
Michael
Hallo!
Noch eine Array-Lösung aus Spaß an der Freude
Sub a()
Dim Wb As Workbook: Set Wb = ThisWorkbook
Dim Ws As Worksheet: Set Ws = Wb.Worksheets("Tabelle1")
Dim c As Range, a, b, i&, j&, k&
With Ws
Set c = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
a = c
ReDim b(1 To UBound(a) / 5, 1 To 5)
For i = 1 To UBound(a, 1) Step 5
For j = 0 To 4
b(1 + k, 1 + j) = a(i + j, 1)
Next j
k = k + 1
Next i
'nicht erwünschte Ausgabe auskommentieren
'Original-Spaltenwerte behalten, Transponiert daneben...
c.Offset(, 1).Resize(UBound(b, 1), UBound(b, 2)) = b
'...oder Original-Spaltenwerte mit transp. Werten ersetzen
c.ClearContents
c.Resize(UBound(b, 1), UBound(b, 2)) = b
End With
Erase a: Erase b
Set Wb = Nothing: Set Ws = Nothing: Set c = Nothing
End Sub
LG
Michael
Anzeige

322 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige