chrissy123
Goto Top

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.
chrissy_1
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

Content-Key: 325234

Url: https://administrator.de/contentid/325234

Ausgedruckt am: 19.03.2024 um 11:03 Uhr

Mitglied: 131381
Lösung 131381 02.01.2017 aktualisiert um 13:02:27 Uhr
Goto Top
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
Mitglied: Chrissy123
Chrissy123 02.01.2017 um 13:05:38 Uhr
Goto Top
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
Mitglied: Chrissy123
Chrissy123 02.01.2017 um 13:08:31 Uhr
Goto Top
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
Mitglied: 131381
Lösung 131381 02.01.2017 aktualisiert um 13:10:26 Uhr
Goto Top
Zitat von @Chrissy123:
Leider berücksichtigt diese Lösung nicht das Referenzproblem.
Darauf kommt es mir an.

Doch das tut sie face-wink, auch die Matrix-Formellösung! Referenz ist ja bei beiden immer dein oben a.g. Referenz-Bereich! Du musst es dir genau anschauen...
Mitglied: Chrissy123
Chrissy123 02.01.2017 um 13:35:27 Uhr
Goto Top
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
Mitglied: Chrissy123
Chrissy123 03.01.2017 um 13:02:00 Uhr
Goto Top
Hallo mikrotik,

durch die Matrix-Lösung bin ich auch durchgestiegen.
Attraktive Variante.
Mitglied: 131381
131381 03.01.2017 um 13:03:58 Uhr
Goto Top
Schön face-smile