CRM ligende system i Excel

Ved hjælp af programmering (VBA = Visual Basic for Applications - programmeringssproget i Office) kan det lade sig gøre.

Hvis du uploader / sender en model - så skal jeg skrive VBA-koden.
@-adresse under min profil.

Option Explicit
Const opsamlingsArkNavn = "Opsummering"
Const antalDageAdvis = 5

Dim antalRækker As Integer
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim antalArk As Integer, ark As Integer, ræknr As Integer

    If Target.Address = "$H$1" Then
        Cancel = True
        Application.ScreenUpdating = False
       
        antalRækker = ActiveCell.SpecialCells(xlLastCell).Row
Rem Slet "gl. rækker"
        If antalRækker > 1 Then
            Range("A2:F" & antalRækker).Select
            Selection.Delete
        End If
       
        ræknr = 2
        Range("A" & ræknr).Select
       
Rem Gennemløb alle ark eksl. Opsummering
        antalArk = ActiveWorkbook.Sheets.Count
       
        For ark = 1 To antalArk
            If Sheets(ark).Name <> opsamlingsArkNavn Then
                checkOpfølgning Sheets(ark).Name, ræknr
            End If
        Next ark
     
        Sheets(opsamlingsArkNavn).Activate
        Columns.AutoFit
     
        If ræknr > 2 Then
            sorterOpfølgningsDato ræknr - 1
        End If
    End If
End Sub
Private Sub checkOpfølgning(arkNavn, ræknr)
Dim opfølgningsDato As Date, ræk As Integer, diff As Integer
    ActiveWorkbook.Sheets(arkNavn).Activate
    antalRækker = ActiveCell.SpecialCells(xlLastCell).Row
   
    For ræk = 3 To antalRækker

        If ActiveSheet.Range("I" & ræk) <> "" And IsDate(ActiveSheet.Range("I" & ræk)) = True Then
            opfølgningsDato = ActiveSheet.Range("I" & ræk)

            diff = DateDiff("d", Now, opfølgningsDato)
            If diff >= 0 And diff <= antalDageAdvis Then
                With ActiveWorkbook.Sheets(opsamlingsArkNavn)
                    .Range("A" & ræknr) = ActiveSheet.Range("A" & ræk)      'Kommune
                    .Range("B" & ræknr) = ActiveSheet.Range("D" & ræk)      'Kunde
                    .Range("C" & ræknr) = ActiveSheet.Range("E" & ræk)      'Kontaktoplysninger
                    .Range("D" & ræknr) = opfølgningsDato
                    .Range("E" & ræknr) = ActiveSheet.Range("J" & ræk)      'Opfølgningstidspunkt
                    .Range("F" & ræknr) = ActiveSheet.Range("K" & ræk)      'Opfølgningsform
                    ræknr = ræknr + 1
                End With
            End If
        End If
    Next ræk
End Sub
Private Sub sorterOpfølgningsDato(ræknr)
    Range("D2").Select
    ActiveWorkbook.Worksheets("Opsummering").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Opsummering").Sort.SortFields.Add Key:=Range( _
        "D2:D" & ræknr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Opsummering").Sort
        .SetRange Range("A1:F" & ræknr)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub