Wie kann ich ein Macro in Excel 2010 erstellen um Daten aus einer Table von horzontal auf vertikal zu kopieren

Computer: Software & Programmierung Office Software
#1

Ich suche nach einer Möglichkeit mit Hilfe eines Macros, Daten aus einer Excel table (Excel 2010) die in horizontaler Form abgebildet sind in ein anderes Excel sheet in vertikaler Form zu kopieren. Spalten die keine Werte in der Ausgang tabele enthalten sollen nach Möglichkeit in der Ausgabe Table nicht mitangezeigt werden. Vielen Dank für hilfreiche Tips.

Excel
Excel1022×306 26.3 KB

#2

Hallo @Falk35

dafür gibt es einen fertigen Befehl „transponieren“.

Erst den Bereich in der Ausgangstabelle markieren, der transponiert werden soll.

Dann mit STRG&C kopieren.

Anschließend in ein leeres Tabellenblatt gehen und „Bearbeiten/Inhalte einfügen“ wählen. Im nun geöffneten Fenster in die Schaltfläche "transponieren " ein Häkchen setzen.

Leerzeilen/Spalten werden dabei nicht entfernt, das musst du händisch machen, evtl. mit einem Filter.

Viel Erfolg
Ullrich Sander

#3

Danke diese Funktion kenne ich schon. Ich möchte das ganze gerne mit einem Macro automatisieren, auch das es sich hier um eine größere Menge an Datensätzen handelt.

#4

Hallo Falk,

hier der VBA-Code!

Bitte den Code sheets(„StartTabelle“) und sheets(„ZielTabelle“) durch ihre individuellen Tabellenblattnamen zwischen den Anführungszeichen ersetzten.
Hier wird davon ausgegangen, dass es sich um eine einfache Tabelle handelt, also Überschriften in 1. Zeile und linker Spalte!

Dann den folgenden Code in Ihr Makro übernehmen und die Tabellenblattnamen wie o.a. korrigieren:

**Dim objZelle As Object
Dim dblAnzahl As Double

Sheets("StartTabelle").UsedRange.Copy
Sheets("Zieltabelle").Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
Application.CutCopyMode = False

**For Each objZelle In Sheets("Zieltabelle").UsedRange.Cells
    If objZelle = "" Then
        dblAnzahl = WorksheetFunction.CountA(objZelle.EntireRow)
        If dblAnzahl < 2 Then
            objZelle.EntireRow.Delete
        End If
    End If
Next objZelle

For Each objZelle In Sheets("Zieltabelle").UsedRange.Cells
    If objZelle = "" Then
        dblAnzahl = WorksheetFunction.CountA(objZelle.EntireColumn)
        If dblAnzahl < 2 Then
            objZelle.EntireColumn.Delete
        End If
    End If
Next objZelle**

Bitte zum Testen erst Kopie Ihrer Daten anfertigen ! ! ! ! !
Alle Angaben ohne irgendeine Gewähr!

Gruß

Hannes

#5

Diese und die Sternchen am Anfang und am Ende natürlich weglassen!

#6

Vielen Dank Hannes!

1 Like