Automatisk sortering efter navne i andre ark

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

    Application.ScreenUpdating = False
    Dim i As Long, j As Long, k As Long
    Dim sNames(3) As String
    Dim lPosts(3) As Long
    For i = 2 To 5
        sNames(i - 2) = Sheets(i).Name
    Next i
    Sheets(1).Select
    j = Range("F3").End(xlDown).Row
    For i = 3 To j
        For k = 0 To 3
            If LCase(Cells(i, 6)) = LCase(sNames(k)) Then
                lPosts(k) = lPosts(k) + 1
                Exit For
            End If
        Next k
    Next i
    Dim Data2() As Variant
    ReDim Data2(lPosts(0), 5)
    Dim Data3() As Variant
    ReDim Data3(lPosts(1), 5)
    Dim Data4() As Variant
    ReDim Data4(lPosts(2), 5)
    Dim Data5() As Variant
    ReDim Data5(lPosts(3), 5)
    Dim Count(3) As Long
    For i = 3 To j
        Select Case LCase(Cells(i, 6))
            Case LCase(sNames(0))
                Count(0) = Count(0) + 1
                For k = 0 To 4
                    Data2(Count(0), k) = Cells(i, k + 1).Value
                Next k
                Data2(Count(0), 5) = Cells(i, 7).Value
            Case LCase(sNames(1))
                Count(1) = Count(1) + 1
                For k = 0 To 4
                    Data3(Count(1), k) = Cells(i, k + 1).Value
                Next k
                Data3(Count(1), 5) = Cells(i, 7).Value
            Case LCase(sNames(2))
                Count(2) = Count(2) + 1
                For k = 0 To 4
                    Data4(Count(2), k) = Cells(i, k + 1).Value
                Next k
                Data4(Count(2), 5) = Cells(i, 7).Value
            Case LCase(sNames(3))
                Count(3) = Count(3) + 1
                For k = 0 To 4
                    Data5(Count(3), k) = Cells(i, k + 1).Value
                Next k
                Data5(Count(3), 5) = Cells(i, 7).Value
        End Select
    Next i
    Sheets(sNames(0)).Select
    j = Range("F3").End(xlDown).Row
    If j < 1000 Then
        Rows("3:" & CStr(j + 5)).Select
        Selection.Delete Shift:=xlUp
    End If
    For i = 1 To UBound(Data2, 1)
        For k = 1 To 5
            Cells(i + 2, k).Value = Data2(i, k - 1)
        Next k
        Cells(i + 2, 6).Value = sNames(0)
        Cells(i + 2, 7).Value = Data2(i, 5)
    Next i
    Rows(CStr(i + 3) & ":" & CStr(i + 3)).Interior.Color = RGB(0, 153, 0)
    Cells(i + 3, 1).Formula = "SUMMEN"
    Cells(i + 3, 2).Formula = "=SUM(B3:B" & CStr(i + 1) & ")"
    Cells(i + 3, 3).Formula = "=SUM(C3:C" & CStr(i + 1) & ")"
    Cells(i + 4, 1).Formula = "DIFF"
    Cells(i + 4, 3).Formula = "=B" & CStr(i + 3) & "+C" & CStr(i + 3)
    Cells(1, 1).Select
    Sheets(sNames(1)).Select
    j = Range("F3").End(xlDown).Row
    If j < 1000 Then
        Rows("3:" & CStr(j + 5)).Select
        Selection.Delete Shift:=xlUp
    End If
    For i = 1 To UBound(Data3, 1)
        For k = 1 To 5
            Cells(i + 2, k).Value = Data3(i, k - 1)
        Next k
        Cells(i + 2, 6).Value = sNames(1)
        Cells(i + 2, 7).Value = Data3(i, 5)
    Next i
    Rows(CStr(i + 3) & ":" & CStr(i + 3)).Interior.Color = RGB(0, 153, 0)
    Cells(i + 3, 1).Formula = "SUMMEN"
    Cells(i + 3, 2).Formula = "=SUM(B3:B" & CStr(i + 1) & ")"
    Cells(i + 3, 3).Formula = "=SUM(C3:C" & CStr(i + 1) & ")"
    Cells(i + 4, 1).Formula = "DIFF"
    Cells(i + 4, 3).Formula = "=B" & CStr(i + 3) & "+C" & CStr(i + 3)
    Cells(1, 1).Select
    Sheets(sNames(2)).Select
    j = Range("F3").End(xlDown).Row
    If j < 1000 Then
        Rows("3:" & CStr(j + 5)).Select
        Selection.Delete Shift:=xlUp
    End If
    For i = 1 To UBound(Data4, 1)
        For k = 1 To 5
            Cells(i + 2, k).Value = Data4(i, k - 1)
        Next k
        Cells(i + 2, 6).Value = sNames(2)
        Cells(i + 2, 7).Value = Data4(i, 5)
    Next i
    Rows(CStr(i + 3) & ":" & CStr(i + 3)).Interior.Color = RGB(0, 153, 0)
    Cells(i + 3, 1).Formula = "SUMMEN"
    Cells(i + 3, 2).Formula = "=SUM(B3:B" & CStr(i + 1) & ")"
    Cells(i + 3, 3).Formula = "=SUM(C3:C" & CStr(i + 1) & ")"
    Cells(i + 4, 1).Formula = "DIFF"
    Cells(i + 4, 3).Formula = "=B" & CStr(i + 3) & "+C" & CStr(i + 3)
    Cells(1, 1).Select
    Sheets(sNames(3)).Select
    j = Range("F3").End(xlDown).Row
    If j < 1000 Then
        Rows("3:" & CStr(j + 5)).Select
        Selection.Delete Shift:=xlUp
    End If
    For i = 1 To UBound(Data5, 1)
        For k = 1 To 5
            Cells(i + 2, k).Value = Data5(i, k - 1)
        Next k
        Cells(i + 2, 6).Value = sNames(3)
        Cells(i + 2, 7).Value = Data5(i, 5)
    Next i
    Rows(CStr(i + 3) & ":" & CStr(i + 3)).Interior.Color = RGB(0, 153, 0)
    Cells(i + 3, 1).Formula = "SUMMEN"
    Cells(i + 3, 2).Formula = "=SUM(B3:B" & CStr(i + 1) & ")"
    Cells(i + 3, 3).Formula = "=SUM(C3:C" & CStr(i + 1) & ")"
    Cells(i + 4, 1).Formula = "DIFF"
    Cells(i + 4, 3).Formula = "=B" & CStr(i + 3) & "+C" & CStr(i + 3)
    Cells(1, 1).Select
    Sheets(1).Select
    Cells(1, 1).Select
    Application.ScreenUpdating = True

End Sub