VBA programmering til CRM-lignende system

Option Explicit
Dim WsSø As Worksheet, WsSl As Worksheet, WsOp As Worksheet
Dim Area_1 As Range, Area_2 As Range, Area As Range
Dim Arr_1() As Variant, Arr_2() As Variant
Dim MellemArr() As Variant, NewArr() As Variant
Dim Rækker As Long, iRow As Integer, iColumn As Integer, Tæl As Integer
Dim Dato As Date

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Target = Range("J1") Then ' tester om der er højreklikket på J1
        Cancel = True ' aflyser højreklikket = ingen højrekliksmenu
        MinKode
    End If
End Sub

Private Sub MinKode()
    ' de 3 ark som en variabel
    Set WsOp = Sheets("Opsummering")
    Set WsSø = Sheets("Søborg")
    Set WsSl = Sheets("Slagelse")
    ' Area_1 ogArea_2= de navngivne områder, hvilket gør det dynamisk
    Set Area_1 = WsSø.Range("Søborg")
    Set Area_2 = WsSl.Range("Slagelse")
    ' Områderne fyldes ind i array's, som arbejder meget - meget hurtigere end direkte på regnearket
    Arr_1 = Area_1
    Arr_2 = Area_2
    ' finder udaf hvormange rækker der er i de to array's
    Rækker = UBound(Arr_1, 1) + UBound(Arr_2, 1)
    Tæl = 0
    ' sætter størrelsen på flette-array'en
    ReDim MellemArr(1 To Rækker, 1 To UBound(Arr_1, 2))
    'fylder de to array's over i flette-array'et
    For iRow = 1 To UBound(Arr_1, 1)
        Tæl = Tæl + 1
        For iColumn = 1 To UBound(Arr_1, 2)
            MellemArr(Tæl, iColumn) = Arr_1(iRow, iColumn)
        Next
    Next
    For iRow = 1 To UBound(Arr_2, 1)
        Tæl = Tæl + 1
        For iColumn = 1 To UBound(Arr_2, 2)
            MellemArr(Tæl, iColumn) = Arr_2(iRow, iColumn)
        Next
    Next
    Tæl = 0
    'sætter variablen Dato til dags dato
    Dato = Format(Now, "dd-mm-yyyy")
    'tester hvormange rækker med deadline
    For iRow = 1 To UBound(MellemArr, 1)
        If MellemArr(iRow, 5) = Dato Then Tæl = Tæl + 1
    Next
    'sætter et nyt array's størrelse
    ReDim NewArr(1 To Tæl, 1 To UBound(MellemArr, 2))
    Tæl = 0
    'fylder deadline rækker over i det nye array
    For iRow = 1 To UBound(MellemArr, 1)
        If MellemArr(iRow, 5) = Dato Then
            Tæl = Tæl + 1
            For iColumn = 1 To UBound(MellemArr, 2)
                NewArr(Tæl, iColumn) = MellemArr(iRow, iColumn)
            Next
        End If
    Next
    ' renser området på opsummerings-arket før data lægges over
    Set Area = WsOp.Range("A2")
    Set Area = Range(Area, Area.End(xlDown).Offset(0, 10))
    Area.ClearContents
    ' sætter området på opsummerings-arket til sammestørrelse som NewArr
    Set Area = WsOp.Range(WsOp.Cells(2, 1), WsOp.Cells(1 + UBound(NewArr, 1), UBound(NewArr, 2)))
    ' fylder array'et over i arket
    Area = NewArr

End Sub