Excel 2007 Transponieren von Gruppen oder Blöcken mit VBA

Hallo, guten Abend und ich bin hier neu.
Leidlich VBA!

Auf der Suche nach einer Lösung bin ich auf diesen Beitrag hier gestoßen:
Makro zum transponieren von Daten

Im Prinzip das gleiche Problem, bei mir soll allerdings eine Referenzliste berücksichtigt werden.
Das schaffe ich (noch) nicht. Im Screenshot sind nur Beispielsdaten.
So sollte es später aussehen.

Die ArtikelNr kommen aus einer DB-Abfrage und sind aufsteigend sortiert.
Sind oft mehrere 1000. Die zugehörigen TeileNr befinden sich in B.
Zu jeder ArtikelNr gibt es eine unterschiedliche Anzahl von TeileNr.

Mit der Referenzliste (auch mehrere hundert), die sich in E befindet sollen die Daten weiter ausgewertet werden.
Ab G sollen die TeileNr dann waagerecht eingetragen werden.
Und nur die von den ArtNr, welche sich in der Referenzlist befinden.

Sub Umstellen()
'[content:202575]  
'angepasst  

QTabelle = "Tabelle1" 'Quelltabelle  
QUeberzeile = 1 'Zeile mit Überschrift für Quelldaten  
QAbSpalte = "A" 'Spalte, ab der die Quelldaten eingetraben sind  
Spalten = 2 'Spaltenanzahl der Quelldaten  
ZTabelle = "Tabelle2" 'Zieltabelle  
ZUeberZeile = 1 'Zeile für Überschriften des Zielbereichs  
ZAbSpalte = "G" 'Zielbereich beginnt in dieser Spalte  

Set QTab = Worksheets(QTabelle)
Set ZTab = Worksheets(ZTabelle)
'Ueber = QTab.Cells(QUeberzeile, QAbSpalte).Resize(1, 1).Value 'Überschriften zwischenspeichern  

QZeile = QUeberzeile + 1
ZZeile = ZUeberZeile
ZAbSpalte = Columns(ZAbSpalte).Column

Artikel = QTab.Cells(QZeile, QAbSpalte).Value
Do While Artikel <> ""  
    If Artikel <> ArtikelVorher Then
        ZZeile = ZZeile + 1
        ZSpalte = ZAbSpalte
        ArtikelVorher = Artikel
    End If
    ZTab.Cells(ZZeile, ZSpalte).Resize(1, 1).Value = QTab.Cells(QZeile, 2).Resize(1, 1).Value
    
    QZeile = QZeile + 1
    ZSpalte = ZSpalte + 1
    Artikel = QTab.Cells(QZeile, QAbSpalte).Value
Loop
End Sub

Der Code funktioniert soweit, dass die TeileNr waagerecht eingesetzt werden - allerdings von allen ArtikelNr

Wäre schön, wenn mir jemand in die Loipe helfen würde.
Ich bedanke mich schon mal

Chrissy

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 325234

Url: https://administrator.de/forum/excel-2007-transponieren-von-gruppen-oder-bloecken-mit-vba-325234.html

Ausgedruckt am: 18.05.2025 um 07:05 Uhr

7 Kommentare

Neuester Kommentar

Moin,
für so eine einfache Aufgabe braucht es noch nicht mal ein Makro, Matrixformel reicht:
S-Verweis mit Wenn-Und, Transponieren????

Wenn es unbedingt VBA sein muss:

Sub TransposeReferenceData()
    Dim cell As Range, intMax As Long
    Application.ScreenUpdating = False
    With ActiveSheet
        For Each cell In .Range("E2:E" & .Cells(Rows.Count, "E").End(xlUp).Row)  
            If cell.Value <> "" Then  
                .Range("A:B").AutoFilter Field:=1, Criteria1:=cell.Value  
                intMax = .Cells(Rows.Count, "B").End(xlUp).Row  
                If intMax > 1 Then
                    .Range("B2:B" & intMax).SpecialCells(xlCellTypeVisible).Copy  
                    cell.Offset(0, 1).PasteSpecial xlPasteValuesAndNumberFormats, Transpose:=True
                End If
            End If
        Next
        .Range("A:B").AutoFilter  
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Gruß mik

Hallo mik,
Danke für die Beschäftigung mit meiner Aufgabe.
Leider berücksichtigt diese Lösung nicht das Referenzproblem.
Darauf kommt es mir an.
Gruß
Chrissy

Hallo mik,
vergiss meinen Schrieb; hatte gar nicht den Code gesehen.
Muss ich erst mal prüfen und melde mich dann noch mal.
Gruß
Chrissy

Zitat von @Chrissy123:
Leider berücksichtigt diese Lösung nicht das Referenzproblem.
Darauf kommt es mir an.

Doch das tut sie

, auch die Matrix-Formellösung! Referenz ist ja bei beiden immer dein oben a.g. Referenz-Bereich! Du musst es dir genau anschauen...

Hallo mikrotik,
deine VBA-Lösung funktioniert einwandfrei.
Durch die Matrix-Lösung bin ich mit der Referenz noch nicht durchgestiegen.
Kommt sicher noch.

Also Danke.
Schönen Tag
Chrissy