Zeilen zusammenfassen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo,
Quelle ist Tabelle1 und die Ausgabe erfolgt auf Tabelle2, eventuell anpassen.

Sub test()
Dim MeAr, tmpAr, ArrItem
Dim oDic As Object
Dim A As Long, B As Long
Dim MaxRow As Long, MaxCol As Long

Set oDic = CreateObject("Scripting.Dictionary")

With Tabelle1 'Tabelle Quelle 
    MeAr = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 4)
End With


For A = 1 To Ubound(MeAr)
    If Not oDic.exists(MeAr(A, 1)) Then
        If MeAr(A, 2) <> "" Then
            oDic(MeAr(A, 1)) = MeAr(A, 2)
        Else
            oDic(MeAr(A, 1)) = ""
        End If
    End If
    
    For B = 3 To Ubound(MeAr, 2)
        If MeAr(A, B) <> "" Then _
        oDic(MeAr(A, 1)) = oDic(MeAr(A, 1)) & ";" & MeAr(A, B)
    Next B
Next A



With Tabelle2 'Tabelle Ziel 
    MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    If MaxRow > 1 Then .Range("A2:A" & MaxRow).Resize(, .Columns.Count).ClearContents
    If oDic.Count > 0 Then
        ArrItem = oDic.Items
        .Cells(2, 1).Resize(oDic.Count) = Application.Transpose(oDic.Keys)
        
        Application.ScreenUpdating = False
        For A = Lbound(ArrItem) To Ubound(ArrItem)
            tmpAr = Split(ArrItem(A), ";")
            .Cells(A + 2, 2).Resize(, Ubound(tmpAr) + 1).Value = tmpAr
            If MaxCol < Ubound(tmpAr) Then MaxCol = Ubound(tmpAr)
        Next A
        
        With .Range("A2", Cells(Rows.Count, 1).End(xlUp)).Resize(, MaxCol + 1)
            tmpAr = .Value2
            
            For A = 1 To Ubound(tmpAr)
                For B = 1 To Ubound(tmpAr, 2)
                    If IsNumeric(tmpAr(A, B)) Then tmpAr(A, B) = tmpAr(A, B) * 1
                Next B
            Next A
            
            .Value = tmpAr
        End With
        Application.ScreenUpdating = True
     End If
End With


Set oDic = Nothing
End Sub

Gruß Tino

Hi Tino,
ich komme nun doch nicht weiter. Ich lade mal eine Bsp.-Datei hoch, die 17 Datensätze enthält und 37 Spalten. https://www.herber.de/bbs/user/70144.xls
An einem Bsp habe ich markiert, was die Ausgangsbasis ist (gelb markiert) und was aus diesen beiden Zeilen als Ergebnis herauskommen soll (grün markiert). Ziel ist es, nur noch eine Zeile pro Projekt zu haben und jede Spalte mit Text/Wert gefüllt ist. Sollte für ein Projekt eine Spaltenüberschrift existieren bei der die entsprechenden Zellen alle leer/blanc sind (im gelb markierten Bsp. Spalte 36 "Used for Summary") dann soll auch in der Ergebniszeile/spalte blanc stehen. Momentan ist der Code so, dass durch die Codezeile
"If MeAr(A, B) "" Then _
oDic(MeAr(A, 1)) = oDic(MeAr(A, 1)) & ";" & MeAr(A, B)"
keine leeren Felder übernommen werden, aber dadurch die Ergebnistabelle zusammenrückt, weil die blancs dazwischen fehlen, aber die Texte/Werte müssen natürlich unter der ursprünglichen Spaltenüberschrift stehen bleiben. Also benötige ich in etwa soetwas, wie einen größten gemeinsamen Nenner für Text/werte (strings), wobei Text/Wert ein blanc überschreibt.
Zudem kommt es zu einem Laufzeitfehler "1004" in Zeile
"With .Range("A2", Cells(Rows.Count, 1).End(xlUp)).Resize(, MaxCol + 1)"
des Codes.
Vielleicht kannst du dir dies ja noch mal ansehen. Ich werde aber voraussichtlich erst am Montag wieder dazukommen, im Forum nachzusehen.
Vielen Dank für deine Mühen.
Viele Grüße
AJ

Sub test() Dim MeAr, varPos, ArData() Dim oDic As Object Dim A As Long, B As Long, MaxRow As Long, MaxCol As Long Set oDic = CreateObject("Scripting.Dictionary") With Tabelle1 'Tabelle Quelle MeAr = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 37) End With Redim Preserve ArData(1 To Ubound(MeAr), 1 To Ubound(MeAr, 2) - 1) For A = 1 To Ubound(MeAr) If Not oDic.exists(MeAr(A, 1)) Then oDic(MeAr(A, 1)) = 0 End If varPos = Application.Match(MeAr(A, 1), oDic.Keys, 0) For B = 2 To Ubound(MeAr, 2) If ArData(varPos, B - 1) = "" Then ArData(varPos, B - 1) = MeAr(A, B) Next B Next A With Tabelle2 'Tabelle Ziel MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row If MaxRow > 1 Then .Range("A2:A" & MaxRow).Resize(, .Columns.Count).ClearContents If oDic.Count > 0 Then .Cells(2, 1).Resize(oDic.Count) = Application.Transpose(oDic.Keys) .Cells(2, 2).Resize(Ubound(ArData), Ubound(ArData, 2)) = ArData End If End With Set oDic = Nothing End Sub

Sub test() Dim MeAr, varPos, ArData() Dim oDic As Object Dim A As Long, B As Long, MaxRow As Long, MaxCol As Long Set oDic = CreateObject("Scripting.Dictionary") With Tabelle1 'Tabelle Quelle MeAr = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 37) End With Redim Preserve ArData(1 To Ubound(MeAr), 1 To Ubound(MeAr, 2) - 1) For A = 1 To Ubound(MeAr) If Not oDic.exists(MeAr(A, 1)) Then oDic(MeAr(A, 1)) = 0 End If varPos = Application.Match(MeAr(A, 1), oDic.Keys, 0) ArData(varPos, 1) = MeAr(A, 2) For B = 3 To Ubound(MeAr, 2) If MeAr(A, B) <> "" And MeAr(A, B) <> "'" Then _ ArData(varPos, B - 1) = MeAr(A, B) Next B Next A With Tabelle2 'Tabelle Ziel MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row If MaxRow > 1 Then .Range("A2:A" & MaxRow).Resize(, .Columns.Count).ClearContents If oDic.Count > 0 Then .Cells(2, 1).Resize(oDic.Count) = Application.Transpose(oDic.Keys) .Cells(2, 2).Resize(Ubound(ArData), Ubound(ArData, 2)) = ArData End If End With Set oDic = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread