Calcolo giorni settimana

Hai un problema con Excel?

Nuova discussione

Calcolo giorni settimana
di trump61 data: 10/10/2015 17:44:58
Ciao a tutti sono di nuovo qui. con questo codice realizzato con il vostro aiuto realizzo uno schema di turno annuale personale. Sono ormai 2 anni che lo uso, oggi per caso ho scoperto che nell'anno bisestile e nell' anno seguente mi sbaglia i giorni della settimana. Nell' anno 2016 bisestile mi mette 27 sab 28 dom 29 lun e fino qui va bene il 1 marzo riparte da lunedi e da li mi sbaglia tutto il resto dell' anno
l'anno dopo il bisestile 27 dom 28 lun 1 marzo mercoledì e di conseguenza sbaglia tutto il resto dell' anno poi magicamente nel 2018 tutto torna funzionare regolarmente a me il codice non mi sembra sbagliato, sicuramente non è così ma non capisco dove sta l'errore.
Qualche anima buona mi da una mano

Sub Crea_Annata()
Dim sh1 As Worksheet: Set sh1 = Worksheets("TurnoAnnuale")
Dim sh2 As Worksheet: Set sh2 = Worksheets("Nomi")
Dim X As Long, Y As Long, W As Long, R As Long, DData As Date
Application.ScreenUpdating = False
Dim T As Single
    T = Timer
    sh2.Columns("K").ClearContents
    R = sh2.Cells(1, 12)
For W = 1 To 3
    For X = 1 To 52
        For Y = 3 To 9
            sh2.Cells(R, 11) = sh2.Cells(X, Y)
            R = R + 1
        Next Y
    Next X
Next W
Y = 3
R = sh2.Cells(6, 12)
sh1.Range("B3:AF31").ClearContents
    For X = 2 To 32
        sh1.Cells(Y, X) = Left(WeekdayName(Weekday(sh1.Cells(2, X) & "/" & sh1.Cells(Y, 1) & "/" & sh1.Cells(1, 1) - 1)), 1)
    Next X
        Y = Y + 2
        sh2.Range(sh2.Cells(R, 11), sh2.Cells(R + 30, 11)).Copy
        sh1.Range("b4").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        R = R + 31
    If sh1.Cells(1, 1) Mod 4 = 0 Then
               For X = 2 To 30
        DData = sh1.Cells(2, X) & "/" & sh1.Cells(Y, 1) & "/" & sh1.Cells(1, 1)
        sh1.Cells(Y, X) = Left(WeekdayName(Weekday(DData - 1)), 1)
         Next X
            'sh1.Cells(Y, X) = Left(WeekdayName(Weekday(sh1.Cells(2, X) & "/" & sh1.Cells(Y, 1) & "/" & sh1.Cells(1, 1) - 1)), 1)
        'Next X
        Y = Y + 2
            sh2.Range(sh2.Cells(R, 11), sh2.Cells(R + 28, 11)).Copy
            sh1.Range("b6").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            R = R + 29
    Else
        For X = 2 To 29
            sh1.Cells(Y, X) = Left(WeekdayName(Weekday(sh1.Cells(2, X) & "/" & sh1.Cells(Y, 1) & "/" & sh1.Cells(1, 1) - 1)), 1)
        Next X
        Y = Y + 2
            sh2.Range(sh2.Cells(R, 11), sh2.Cells(R + 27, 11)).Copy
            sh1.Range("b6").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            R = R + 28
    End If
    For X = 2 To 32
        sh1.Cells(Y, X) = Left(WeekdayName(Weekday(sh1.Cells(2, X) & "/" & sh1.Cells(Y, 1) & "/" & sh1.Cells(1, 1) - 1)), 1)
        'sh1.Cells(Y, X) = Left(WeekdayName(Weekday(sh1.Cells(2, X) & "/" & sh1.Cells(Y, 1) & "/" & sh1.Cells(1, 1))), 1)
    Next X
        Y = Y + 2
        sh2.Range(sh2.Cells(R, 11), sh2.Cells(R + 30, 11)).Copy
        sh1.Range("b8").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        R = R + 31
    For X = 2 To 31
        sh1.Cells(Y, X) = Left(WeekdayName(Weekday(sh1.Cells(2, X) & "/" & sh1.Cells(Y, 1) & "/" & sh1.Cells(1, 1) - 1)), 1)
    Next X
        Y = Y + 2
        sh2.Range(sh2.Cells(R, 11), sh2.Cells(R + 29, 11)).Copy
        sh1.Range("b10").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        R = R + 30
    For X = 2 To 32
        sh1.Cells(Y, X) = Left(WeekdayName(Weekday(sh1.Cells(2, X) & "/" & sh1.Cells(Y, 1) & "/" & sh1.Cells(1, 1) - 1)), 1)
    Next X
        Y = Y + 2
        sh2.Range(sh2.Cells(R, 11), sh2.Cells(R + 30, 11)).Copy
        sh1.Range("b12").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        R = R + 31
    For X = 2 To 31
        sh1.Cells(Y, X) = Left(WeekdayName(Weekday(sh1.Cells(2, X) & "/" & sh1.Cells(Y, 1) & "/" & sh1.Cells(1, 1) - 1)), 1)
    Next X
        Y = Y + 2
        sh2.Range(sh2.Cells(R, 11), sh2.Cells(R + 29, 11)).Copy
        sh1.Range("b14").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        R = R + 30
    For X = 2 To 32
        sh1.Cells(Y, X) = Left(WeekdayName(Weekday(sh1.Cells(2, X) & "/" & sh1.Cells(Y, 1) & "/" & sh1.Cells(1, 1) - 1)), 1)
    Next X
        Y = Y + 2
        sh2.Range(sh2.Cells(R, 11), sh2.Cells(R + 30, 11)).Copy
        sh1.Range("b16").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        R = R + 31
    For X = 2 To 32
        sh1.Cells(Y, X) = Left(WeekdayName(Weekday(sh1.Cells(2, X) & "/" & sh1.Cells(Y, 1) & "/" & sh1.Cells(1, 1) - 1)), 1)
    Next X
        Y = Y + 2
        sh2.Range(sh2.Cells(R, 11), sh2.Cells(R + 30, 11)).Copy
        sh1.Range("b18").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        R = R + 31
    For X = 2 To 31
        sh1.Cells(Y, X) = Left(WeekdayName(Weekday(sh1.Cells(2, X) & "/" & sh1.Cells(Y, 1) & "/" & sh1.Cells(1, 1) - 1)), 1)
    Next X
        Y = Y + 2
        sh2.Range(sh2.Cells(R, 11), sh2.Cells(R + 29, 11)).Copy
        sh1.Range("b20").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        R = R + 30
    For X = 2 To 32
        sh1.Cells(Y, X) = Left(WeekdayName(Weekday(sh1.Cells(2, X) & "/" & sh1.Cells(Y, 1) & "/" & sh1.Cells(1, 1) - 1)), 1)
    Next X
        Y = Y + 2
        sh2.Range(sh2.Cells(R, 11), sh2.Cells(R + 30, 11)).Copy
        sh1.Range("b22").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        R = R + 31
    For X = 2 To 31
        sh1.Cells(Y, X) = Left(WeekdayName(Weekday(sh1.Cells(2, X) & "/" & sh1.Cells(Y, 1) & "/" & sh1.Cells(1, 1) - 1)), 1)
    Next X
        Y = Y + 2
        sh2.Range(sh2.Cells(R, 11), sh2.Cells(R + 29, 11)).Copy
        sh1.Range("b24").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        R = R + 30
    For X = 2 To 32
        sh1.Cells(Y, X) = Left(WeekdayName(Weekday(sh1.Cells(2, X) & "/" & sh1.Cells(Y, 1) & "/" & sh1.Cells(1, 1) - 1)), 1)
    Next X
        Y = Y + 2
        sh2.Range(sh2.Cells(R, 11), sh2.Cells(R + 30, 11)).Copy
        sh1.Range("b26").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.ScreenUpdating = True
'MsgBox "Eseguito in :" & " " & Timer - T & " " & " minuti/secondi"
Set sh1 = Nothing
Set sh2 = Nothing
riposiea
Pasqua
colorasabato
coloradomenica
griglia
Range("B1").Select

End Sub

di trump61 data: 10/10/2015 18:31:00
ho inserito un file di esempio

di trump61 data: 10/10/2015 19:19:25
Scusate sto facendo tutto da solo ma mi ci sono incaponito. Ho provato a sezionare il codice e da solo funziona bene, per questo non riesco a spiegarmi dove è l'errore.
Con questa parte di codice verifica e è un anno bisestile
If sh1.Cells(1, 1) Mod 4 = 0 Then
con questa compila i giorni della settimana di febbraio dell' anno prescelto e lo fa esattamente
For X = 2 To 30
DData = sh1.Cells(2, X) & "/" & sh1.Cells(Y, 1) & "/" & sh1.Cells(1, 1)
sh1.Cells(Y, X) = Left(WeekdayName(Weekday(DData - 1)), 1)
Next X
'sh1.Cells(Y, X) = Left(WeekdayName(Weekday(sh1.Cells(2, X) & "/" & sh1.Cells(Y, 1) & "/" & sh1.Cells(1, 1) - 1)), 1)
'Next X
Y = Y + 2
sh2.Range(sh2.Cells(R, 11), sh2.Cells(R + 28, 11)).Copy
sh1.Range("b6").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
R = R + 29
Else
For X = 2 To 29
sh1.Cells(Y, X) = Left(WeekdayName(Weekday(sh1.Cells(2, X) & "/" & sh1.Cells(Y, 1) & "/" & sh1.Cells(1, 1) - 1)), 1)
Next X
Y = Y + 2
sh2.Range(sh2.Cells(R, 11), sh2.Cells(R + 27, 11)).Copy
sh1.Range("b6").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
R = R + 28
End If
For X = 2 To 32
Copiando correttamente anche i turni
con quest' altra parte fa la stessa cosa con marzo
For X = 2 To 32
sh1.Cells(Y, X) = Left(WeekdayName(Weekday(sh1.Cells(2, X) & "/" & sh1.Cells(Y, 1) & "/" & sh1.Cells(1, 1) - 1)), 1)
'sh1.Cells(Y, X) = Left(WeekdayName(Weekday(sh1.Cells(2, X) & "/" & sh1.Cells(Y, 1) & "/" & sh1.Cells(1, 1))), 1)
Next X
Y = Y + 2
sh2.Range(sh2.Cells(R, 11), sh2.Cells(R + 30, 11)).Copy
sh1.Range("b8").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
R = R + 31
da qui esce l'errore ma non capisco perchè soltanto nell'anno bisestile e l'anno seguente.

Sub prova()
Dim sh1 As Worksheet: Set sh1 = Worksheets("Foglio1")
Dim X, Y As Long
sh1.Cells(3, 1) = Left(WeekdayName(Weekday(sh1.Cells(1, 1) - 1)), 1)
sh1.Cells(2, 1) = WeekdayName(Weekday(sh1.Cells(1, 1) - 1))

End Sub

di Mister_x (utente non iscritto) data: 10/10/2015 21:16:12
ciao

manca una funzione

DATA.VALORE() da testo a numeroseriale
vba datevalue() conversione

se non metti la conversione avrai sempre l'anno 1900

metti questa in tutte le tue formule

ciao

For X = 2 To 32
        sh1.Cells(Y, X) = Left(WeekdayName(Weekday(DateValue(sh1.Cells(2, X) & "/" & sh1.Cells(Y, 1) & "/" & sh1.Cells(1, 1)))), 1)
        'sh1.Cells(Y, X) = Left(WeekdayName(Weekday(sh1.Cells(2, X) & "/" & sh1.Cells(Y, 1) & "/" & sh1.Cells(1, 1))), 1)
    Next X

di trump61 data: 11/10/2015 00:45:11
Ti ringrazio per la tua risposta ma non cambia il risultato
di Mister_x (utente non iscritto) data: 11/10/2015 22:34:07
ciao

ero via mancava un altro parametro alla funzione Weekday()

ti posto il file con le modifiche

ciao
di trump61 data: 11/10/2015 23:42:59
Grazie, ilnumero due serve per portare a lunedì l'inizio della settimana giusto?
mi chiedo perchè avevo messo -1, mah ????

Vuoi Approfondire?