Zellvergleich

Option Explicit
Option Compare Text


Sub CreateCostTable()
    Dim Scr As Worksheet, Des As Worksheet, Kst, Anz, Org As String, Cpy As String
    Dim Clr(0 To 254), EndLine As Long, Line As Long, r As Long, i As Integer, n As Integer
    
    On Error GoTo Ende

    Set Scr = Sheets("extUser"):  Set Des = Sheets("Berechnung")  
    
    With Des
       .Cells.Clear
        Application.ScreenUpdating = False
        
        Scr.Range("R:S,V:V").Copy Destination:=.Range("A1"): .Range("A1:C1").Clear  
      
       .Columns("A:C").Sort Key1:=.Range("A1"), Key2:=.Range("B1"), _  
                            Key3:=.Range("C1"), OrderCustom:=1  
    
        EndLine = .Cells(.Rows.Count, 2).End(xlUp).Row
        
        For r = 1 To EndLine
            If Not .Cells(r, 1) Like Cpy Then Cpy = .Cells(r, 1):  Org = ""  
            If Not .Cells(r, 2) Like Org Then
                Org = .Cells(r, 2):  Line = r:  i = 0:  n = 0
                Kst = Clr:  Anz = Clr:  Kst(0) = .Cells(r, 3):  Anz(0) = 1
            Else
                If Not .Cells(r, 3) Like Kst(i) Then
                    i = i + 1:  Kst(i) = .Cells(r, 3):  n = n + 1:  Anz(n) = 1
                Else
                    Anz(n) = Anz(n) + 1
                End If
            End If
            If Not .Cells(r + 1, 2) Like Org Then
                .Range(.Cells(Line, 3), .Cells(Line, 256)) = Kst
                .Range(.Cells(Line, 3), .Cells(Line, 256)).NumberFormat = "@"  
                .Range(.Cells(Line + 1, 3), .Cells(Line + 1, 256)) = Anz
                .Range(.Cells(Line + 2, 1), .Cells(r, 3)).Clear
            End If
        Next
       .Cells.Sort Key1:=.Range("A1")  
    End With
Ende:
    If Err Then MsgBox "Die Kostenstellenaufzählung ist fehlgeschlagen.", vbExclamation, "Fehler"  
    Application.ScreenUpdating = True

End Sub