Betinget kopering VBA

Har du mulighed for at uploade filen - eller en model.

Har du email adresse jeg kan sende til?

Ja - se under min profil

Rem *** TILGANG ***
Const tilgangArkNavn = "Tilgang"
Const tilgangDatoer = "C4:N4"
Const tilgangTotaler = "C30:N30"

Rem *** TOTAL ***
Const totalArkNavn = "Total"
Const totalDatoer = "D2:ND2"
Const totalTotalerStart = "D30"
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Address = "$A$4" Then
        Cancel = True
        kopierTilTotal
    End If
End Sub
Private Sub kopierTilTotal()
Dim tilgangKolonne As Integer, tilgangTotal As Long
Dim tilgangDato As Date
Dim totalKolonne As Integer
    Application.ScreenUpdating = False
   
    For Each cc In Range(tilgangDatoer).Cells
        tilgangDato = cc
        tilgangTotal = cc.Offset(26, 0)
       
        kopier tilgangDato, tilgangTotal
    Next
End Sub
Private Sub kopier(dato, total)
Dim kol As Integer
    Sheets(totalArkNavn).Activate
    kol = DateDiff("d", "01-01-" & CStr(Year(Now)), dato)
    ActiveSheet.Range(totalTotalerStart).Offset(0, kol) = total
    Sheets(tilgangArkNavn).Activate
End Sub

Accept/Afvisning af svar udbedes - så tråden kan lukkes.