Macro magique

C

cheyenne63

XLDnaute Occasionnel
Bonjour
Comment créer en un tour de main (par macro) un calendrier annuel complet sous la forme présentée dans le classeur joint (la colonne B revient toutes les 12 lignes).
Par exemple en sélectionnant l’année 2015 (la semaine 1 commence le 29/12/2014 et l’année se termine le 03/01/2016 avec la semaine 53) dans un USF ?
Car ligne après ligne s’est un peu long à faire …
Si on pouvait respecter aussi un changement de couleur (jour après jour) comme dans l’exemple joint, ce serait parfait.
Merci d’avance
 

Pièces jointes

  • Classeur2.xlsm
    16.6 KB · Affichages: 76
  • Classeur2.xlsm
    16.6 KB · Affichages: 84
  • Classeur2.xlsm
    16.6 KB · Affichages: 84
Trier par date Trier par votes
Staple1600

Staple1600

XLDnaute Barbatruc
Re : Macro magique

Bonjour à tous


En attendant une solution all in one à base de tableaux ;)
Un solution non finalisée (au niveau du format des cellules)
Pour tester, lancer la macro calendrier
Code: 
Sub calendrier()
Application.ScreenUpdating = False
etape1
etape2
etape3
etape4
Application.ScreenUpdating = True
End Sub
Private Sub etape1()
Dim PremJour
PremJour = InputBox("Premier jour du calendrier?", "Calendrier", Date)
Range("A2") = CDate(PremJour)
Range("A2").Resize(366).DataSeries Rowcol:=xlColumns, Type:=xlChronological, Date:=xlDay, Step:=1, Trend:=False
End Sub
Private Sub etape2()
Dim i&
With ActiveSheet
        i = .Cells(.Rows.Count, "A").End(xlUp).Row
Do While i <> 2
Rows(i & ":" & i + 10).Insert
i = i - 1
Loop
End With
End Sub
Private Sub etape3()
Dim dl&
With ActiveSheet
        dl = .Cells(.Rows.Count, "A").End(xlUp).Row + 10
End With
With Range("A2:A" & dl)
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
End Sub
Private Sub etape4()
Dim Vals, dl&
Vals = Array("ADD", "GFT", "FRE", "HJK", "FGT", "RET", "LMP", "JJU", "TYU", "FGR", "AZE ", "EZS")
[B2:B13] = Application.Transpose(Vals)
With ActiveSheet
        dl = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("B2:B13").AutoFill Destination:=.Range("B2:B" & dl), Type:=xlFillCopy
End With
End Sub

EDITION: Bonjour job75
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro magique

Bonjour cheyenne63, CISCO,

CISCO à dit:
En B14, tu écris = B2, et tu tires vers le bas... Simple, non.
Cliquez pour agrandir...

Eh oui hypersimple, et en A14 on écrira =A2+1 !!!

Pour les couleurs sélectionner les colonnes A:B en entier et créer une Mise en forme conditionnelle à 2 conditions :

Code: 
=$A1*MOD($A1;2)
Code: 
=$A1*NON(MOD($A1;2))
Edit : salut Jean-Marie, je ne t'avais pas vu.

A+
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro magique

Re, salut JC,

Je passe mon temps sur ce forum à faire du VBA :rolleyes:

Mais quand comme ici il est inutile je refuse de l'utiliser.

Voyez le fichier joint sur 53 semaines soit 53 x 7 x 12 = 4452 lignes.

L'année est donnée par la liste de validation en B1.

Edit : pardon Jean-Claude, même solution que toi :)

A+
 

Pièces jointes

  • Calendrier(1).xlsx
    106.5 KB · Affichages: 33
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro magique

Re,

Ah mais si, VBA est utile.

Pour masquer les jours avant ou après l'année choisie en B1 :

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B1]) Is Nothing Then Exit Sub
[L3] = ""
If [B1] = "" Then On Error Resume Next: Me.ShowAllData: Exit Sub
[L3] = "=YEAR(A3)=B$1"
[A2:K4454].AdvancedFilter xlFilterInPlace, [L2:L3] 'filtre avancé
End Sub
Pour tout afficher effacer B1.

Fichier joint.

Bonne nuit.
 

Pièces jointes

  • Calendrier VBA(1).xlsm
    111.8 KB · Affichages: 38
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro magique

Bonjour cheyenne63, le forum,

Les données des colonnes C à K sont a priori modifiées chaque année.

Il faut donc prévoir une feuille par année.

Dans ce cas placer dans ThisWorkbook :

Code: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Source As Range)
With Sh
  If Not .Name Like "####" Or Intersect(Source, .[A1]) Is Nothing Then Exit Sub
  Application.ScreenUpdating = False
  On Error Resume Next: .ShowAllData: On Error GoTo 0
  If .[A1] = "" Then Exit Sub
  .[L3] = "=YEAR(A3)=A$1"
  .[A2:K4454].AdvancedFilter xlFilterInPlace, .[L2:L3] 'filtre avancé
End With
End Sub
Fichier (2).

A+
 

Pièces jointes

  • Calendrier VBA(2).xlsm
    654.3 KB · Affichages: 41
Dernière édition:
Vote positif 0 Vote négatif
Regueiro

Regueiro

XLDnaute Impliqué
Re : Macro magique

Bonsoir le Forum, Cheyenne63, Job75
Voici avec une macro
Aller sur la Feuille Planning, B2 Liste de Validation avec choix de l'année
Ensuite lancer la Macro, Bouton GO

Code: 
Option Explicit
Sub Création_Calendrier()
Dim Début, Fin As Date
Dim i As Date
Dim Cell As Range, li&
Dim C As Range
Dim dl&

Début = Sheets("PLANNING").Range("B2").Value
Fin = Sheets("PLANNING").Range("B3").Value
Set Cell = Sheets("PLANNING").Range("A5")
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
li = Cell.Row

    For i = Début To Fin
        Cells(li, 1).Select
                With Selection
                    .Value = i
                    .NumberFormatLocal = "jjjj jj mmmm aaaaa"
                    .HorizontalAlignment = xlLeft
                    .InsertIndent 1
                   ' .Borders.Weight = xlThin
                   .Font.Bold = True
                End With
                li = li + 12
    Next i
    
    With ActiveSheet
        dl = .Cells(.Rows.Count, "A").End(xlUp).Row + 11
    End With

For Each C In Range("A5:A" & dl)
    If C.Value = "" Then
        C.FormulaR1C1 = "=R[-1]C"
        C.Value = C.Value
        C.Font.Bold = True
        C.HorizontalAlignment = xlLeft
        C.InsertIndent 1
    End If
Next C
Etape1

For Each C In Range("A5:A" & dl)
'Select Case Weekday(DateSerial(An, mois, C), vbMonday)
Select Case Weekday(C, vbMonday)
Case 1, 3, 5    'Lundi, Mercredi, Vendredi
C.Resize(, 2).Interior.ColorIndex = 44
Case 2, 4         'mardi, jeudi
C.Resize(, 2).Interior.ColorIndex = 6
Case 6              'Samedi
C.Resize(, 2).Interior.ColorIndex = 20
Case 7              'Dimanche
C.Resize(, 2).Interior.ColorIndex = 37
End Select
Next C
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    End With
End Sub
Sub efface()
Dim dl&
With ActiveSheet
        dl = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With Range("A5:B" & dl)
.ClearContents                      'Efface
.Interior.Pattern = xlNone
.HorizontalAlignment = xlLeft
.IndentLevel = 0
End With
End Sub
Sub Etape1()
Dim Vals, dl&
Vals = Array("ADD", "GFT", "FRE", "HJK", "FGT", "RET", "LMP", "JJU", "TYU", "FGR", "AZE ", "EZS")
[B5:B16] = Application.Transpose(Vals)
With ActiveSheet
        dl = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("B5:B16").AutoFill Destination:=.Range("B5:B" & dl), Type:=xlFillCopy
        .Range("B5:B" & dl).Font.Bold = True
End With
End Sub
A+
 

Pièces jointes

  • PLANNING ANNUEL.xlsm
    74.4 KB · Affichages: 31
  • PLANNING ANNUEL.xlsm
    74.4 KB · Affichages: 38
  • PLANNING ANNUEL.xlsm
    74.4 KB · Affichages: 40
Vote positif 0 Vote négatif

Discussions similaires

E
  • Question
Microsoft 365 VBA Calendrier, rien ne se passe.
Réponses
12
Affichages
687
fanch55
fanch55
S
  • Question
XL 2010 Macro saut de page adaptable selon dates TCD
Réponses
9
Affichages
1 K
safranien
S
Magic_Doctor
  • Question
XL 2010 Une fonction qui sature
Réponses
8
Affichages
1 K
Magic_Doctor
Magic_Doctor
P
  • Question
Calendrier avec cellules fixes
Réponses
12
Affichages
1 K
Pia
P
I
  • Question
XL pour MAC RESOLU - Calcul mensuel d'utilisateurs multiples sur fichier importé
Réponses
4
Affichages
903
Imrin
I
L
  • Question
Tableau de bord
Réponses
6
Affichages
939
loulourav
L
S
  • Question
MIN/MAX et formule matricielle
Réponses
3
Affichages
4 K
Modeste geedee
Modeste geedee
M
  • Question
Comparer 2 listes avec une macro
Réponses
6
Affichages
2 K
Maryloo2005
M
E
  • Question
"Ranger" des Valeurs dans des cellules - Planning Annuel
2
Réponses
21
Affichages
3 K
ETI
E
L
  • Question
recherche aide gestion erreur macro excel
Réponses
7
Affichages
923
Efgé
Efgé

Membres actuellement en ligne

9 membres et 69 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 508
Messages
2 089 138
Membres
104 047
dernier inscrit
bravetta