Aufbereitung Daten

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Makro3()
    Dim TB1, LR1 As Double, LR2 As Double, i As Double, j As Double
    Dim Trenner As String
    
    
    Set TB1 = Sheets("KST_04_2018")
    Trenner = ", "
    
    LR1 = TB1.Cells(TB1.Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte 
    
    ActiveWorkbook.Sheets.Add after:=Sheets(Sheets.Count)
    Application.ScreenUpdating = False
    
    With ActiveSheet
        TB1.Columns(3).Copy .Columns(1)
        .Cells(1, 2) = TB1.Cells(1, 1) 'Überschrift 
        .Columns(2).NumberFormat = "@" 'als Texte 
        
        .Columns(1).RemoveDuplicates Columns:=1, Header:=xlYes 'Doppelte raus 
        
        LR2 = .Cells(.Rows.Count, 1).End(xlUp).Row
        
        With .Sort 'sortieren 
            .SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange Columns(1)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        For i = 2 To LR2 'Für alle Namen 
            For j = 2 To LR1 'alle Kostenstellen durchlaufen 
                If TB1.Cells(j, 3) = .Cells(i, 1) Then
                    .Cells(i, 2) = .Cells(i, 2) & TB1.Cells(j, 1) & Trenner
                End If
            Next j
            
            If Right(.Cells(i, 2), 2) = Trenner Then _
                .Cells(i, 2) = Left(.Cells(i, 2), Len(.Cells(i, 2)) - 2) 'letzten Trenner löschen 
            
        Next i

    End With
End Sub

LG UweD

Sub Makro3() Dim TB1, TB2, LR1 As Double, LR2 As Double, i As Double, j As Double Dim Trenner As String Set TB1 = Sheets("Tabelle1") Set TB2 = Sheets("Tabelle2") Trenner = ", " With TB2 .Cells.ClearContents 'reset .Cells(1, 2) = TB1.Cells(1, 1) 'Überschrift TB1.Columns(3).Copy .Columns(1) .Columns(1).RemoveDuplicates Columns:=1, Header:=xlYes LR1 = TB1.Cells(TB1.Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte LR2 = .Cells(.Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte For i = 2 To LR2 For j = 2 To LR1 If TB1.Cells(j, 3) = .Cells(i, 1) Then .Cells(i, 2) = .Cells(i, 2) & TB1.Cells(j, 1) & Trenner End If Next j If Right(.Cells(i, 2), 2) = Trenner Then _ .Cells(i, 2) = Left(.Cells(i, 2), Len(.Cells(i, 2)) - 2) 'letzten Trenner löschen Next i End With End Sub

Beliebteste Forumthreads (12 Monate)

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread