génération calendrier

[cmalifarge]

Bonjour,
j'utilise le code ci dessous pour générer un calendrier. j'aimerai intercaler 4 colonnes entre chaque mois.
Est ce que cela est possible? et quelqu'un aurait il une solution?

Dim Cal As Range, cell As Range

Set Cal = Range("B4:M34")
Cal.ClearComments

For Each cell In Cal
If cell.Text <> "" Then
If Weekday(cell.Value2, vbMonday) = 1 Then
cell.AddComment "Semaine " & NoSem(cell.Value)
cell.Comment.Shape.TextFrame.AutoSize = True
End If
End If
Next cell

End Sub


Function NoSem(D As Date) As Long
'L. Longre
D = Int(D)
NoSem = DateSerial(Year(D + (8 - Weekday(D)) Mod 7 - 3), 1, 1)
NoSem = ((D - NoSem - 3 + (Weekday(NoSem) + 1) Mod 7)) \ 7 + 1
End Function

Bien cordialement

 

[JCGL]

Bonjour à tous,

Je ne vois rien dans le code qui risque de créer un calendrier.

A+ à tous

 

[Staple1600]

Bonsoir à tous, JCGL

Un petit plus 😉

Sub Calendrier()
Dim X&, i&, cal As Range, cell As Range
'le petit plus
ANNEE = InputBox("Choisir l'année du calendrier?", "Calendrier", Year(Date))
FD = CDate("1/1/" & ANNEE): [B4] = FD: [B4:M4].DataSeries 1, 3, 3, 1
For i = 1 To 12
X = Day(DateSerial(Year(Cells(4, i + 1)), Month(Cells(4, i + 1)) + 1, 0))
Cells(4, i + 1).Resize(X).DataSeries 2, 3, 1, 1
Next
'fin du petit plus
'///////////////////////////
Set cal = [B4].CurrentRegion
cal.ClearComments
For Each cell In cal
If cell.Text <> "" Then
If Weekday(cell.Value2, vbMonday) = 1 Then
cell.AddComment "Semaine " & NoSem(cell.Value)
cell.Comment.Shape.TextFrame.AutoSize = True
End If
End If
Next cell
End Sub

 

[cmalifarge]

Merci, je vais tester ça
Bonne soirée

 

[Staple1600]

Re à tous

En ajoutant les 4 colonnes entre chaque mois.

Sub Calendrier_BIS()
Dim X&, i&, cal As Range, cell As Range
'le petit plus
Application.ScreenUpdating = False
Cells.Clear
ANNEE = InputBox("Choisir l'année du calendrier?", "Calendrier", Year(Date))
FD = CDate("1/1/" & ANNEE): [B4] = FD
[B4:F4].AutoFill Destination:=Range("B4:BE4"), Type:=xlFillMonths
For i = 2 To 57 Step 5
X = Day(DateSerial(Year(Cells(4, i)), Month(Cells(4, i)) + 1, 0))
Cells(4, i).Resize(X).DataSeries 2, 3, 1, 1
Next
'fin du petit plus
'///////////////////////////
Set cal = [B4:BE34]
cal.ClearComments
For Each cell In cal
If cell.Text <> "" Then
If Weekday(cell.Value2, vbMonday) = 1 Then
cell.AddComment "Semaine " & NoSem(cell.Value)
cell.Comment.Shape.TextFrame.AutoSize = True
End If
End If
Next cell
End Sub

 

[JCGL]

Bonjour à tous,

Idem avec une bonne partie du code de l'Agrafe.

A+ à tous