Dublikate zusammenfassen per VBA

letztespalte = Sheets(a).Cells(1, 256).End(xlToLeft).Column For h = Sheets(a).Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 If Sheets(a).Cells(h, 1) = Sheets(a).Cells(h - 1, 1) Then For j = 2 To letztespalte Sheets(a).Cells(h - 1, j) = Sheets(a).Cells(h, j) & Chr(10) & Sheets(a).Cells(h - _ 1, j) Next Sheets(a).Rows(h).Delete End If Next

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
kannst mal so versuchen.
Da ich Deinen genauen aufbau nicht kenne, bin ich vom Beispiel ausgegangen.
Hinweis: Die Datei nicht als xlms, xlsb oder xls speichern, xlsx kann kein VBA!

Sub Test()
Dim ArErg, ArData
Dim oDic(2) As Object
Dim n&
Dim sUmbruch$, sTemp$

On Error GoTo ErrorHandler

Application.ScreenUpdating = False
Application.EnableEvents = False

For n = 0 To 2
    Set oDic(n) = CreateObject("Scripting.Dictionary")
Next n

'Datenbereich evtl. anpassen 
With Tabelle1
    ArData = .Range("B3:D9")
End With

For n = Ubound(ArData) To 1 Step -1
    sUmbruch = IIf(oDic(1)(ArData(n, 1)) <> "", Chr(10), "")
    oDic(0)(ArData(n, 1)) = ArData(n, 1)
    sTemp = ArData(n, 2)
    If InStr(oDic(1)(ArData(n, 1)), sTemp) > 0 Then sTemp = ""
    oDic(1)(ArData(n, 1)) = sTemp & sUmbruch & oDic(1)(ArData(n, 1))
    oDic(2)(ArData(n, 1)) = ArData(n, 3) & sUmbruch & oDic(2)(ArData(n, 1))
Next n

'Ausgabe 
With Tabelle1
    With .Range("B17") 'erste einfüge Zelle 
        'alte Daten löschen 
        .Parent.Range(.Cells, .Parent.Cells(.Parent.Rows.Count, .Column)).Resize(, 3).Clear
        'einfügen und Formatieren 
        If oDic(0).Count > 0 Then
            With .Resize(oDic(0).Count, 3)
                .WrapText = True
                .Columns(1).Value = Application.Transpose(oDic(0).items)
                .Columns(2).Value = Application.Transpose(oDic(1).items)
                .Columns(3).Value = Application.Transpose(oDic(2).items)
                .Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlNo
                .Borders(xlEdgeLeft).Weight = xlMedium
                .Borders(xlEdgeRight).Weight = xlMedium
                .Borders(xlEdgeBottom).Weight = xlMedium
                .EntireRow.AutoFit
            End With
        End If
    End With
End With

ErrorHandler:

Application.ScreenUpdating = True
Application.EnableEvents = True

If Err.Number <> 0 Then
    MsgBox Err.Description, _
           vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
           "Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End If
End Sub

Gruß Tino

Hi tino,
erstmal vielen dank und sorry für meine späte antwort.
ich habe durch meine beispieldatei wohl etwas verwirrt.
du hast es natürlich so interpretiert, wie ich es dargestellt habe.
ich meinte allerdings eher eine zusammenfassung in der ursprünglichen zeile. also keine ausgabe in b17 etc. sondern eine ersätzung der gleichen zeilen.
sorry für die verwirrende datei. ich habe nochmal eine datei hochgeladen mit 2 blättern(vorher und nachher), welche jetzt sehr nah am original ist. ich hoffe dadurch wird es klarer.
das ganze soll natürlich im gleichen tabellenblatt ablaufen und nicht in 2 verschiedenen.

Die Datei https://www.herber.de/bbs/user/93846.xlsm wurde aus Datenschutzgründen gelöscht

Beliebteste Forumthreads (12 Monate)

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread