XL 2019 Fusionner jusqu'à dernière colonne contenant

Nicolas JACQUIN

XLDnaute Occasionnel
Supporter XLD
Bonjour à tous,
Je me suis relancé dans les calendriers, mais tous sur la même ligne, mais je n'arrive pas à fusionner le n° de la dernière semaine du mois, soit dans mon cas pour le mois de mai le 31, que la fusion de cellule se termine en "AG"
J'espère que c'est assez clair.

Pour l'instant ça donne ça :
Capture d’écran 2024-05-21 183234.jpg


Mais je voudrais ça :

Capture d’écran 2024-05-21 185047.jpg


et voici le code à mettre dans un module

VB:
Sub test1()
    Agenda1 2024, 5   'année puis mois
End Sub

Function Agenda1(année, Mois)
Dim i As Long, col As Long, lig As Long, lig2 As Long, nbjour As Long
Dim derlig As Long, dercol As Long, j As Integer, difeuro As Long

Application.DisplayAlerts = False: Application.ScreenUpdating = False

nbjour = Day(DateSerial(année, Mois + 1, 0))    ' te donne le nombre de jour dans le mois en parametre
If Weekday(DateSerial(année, 1, 1), vbMonday) > 4 Then difeuro = 1 ' 1 si semaine commence apres jeudi

With Worksheets("Feuil1")

    Cells.Delete
 
lig = 2: col = 3

For i = 1 To nbjour
 
    .Cells(lig, col) = WorksheetFunction.Proper(Format(DateSerial(année, Mois, i), "dddd"))
    .Cells(1, 3) = "Semaine " & " " & val(Format(DateSerial(année, Mois, 1), "WW", vbMonday)) - difeuro ' numero semaine
    .Cells(lig - 1, col) = IIf(.Cells(lig, col) Like "Lundi", "Semaine " & " " & val(Format(DateSerial(année, Mois, i), "WW", vbMonday)) - difeuro, "") ' numero semaine
    .Cells(lig + 1, col) = (Format(DateSerial(année, Mois, i), "dd" & " " & "mmmm" & " " & année))
 
col = col + 1
Next
 
''''''''''''''''''''''''''''''''''''''''Fusion cellule''''''''''''''''''''''''''''''''''''''''''''
derlig = .Range("A" & Rows.Count).End(xlUp).Row: dercol = .Cells(2, Columns.Count).End(xlToLeft).Column
col = 3

For m = 3 To dercol

    If .Cells(2, col) Like "*Dimanche*" Then
     
        .Range(Cells(1, col + 1), Cells(1, col + 7)).MergeCells = True
        .Range(Cells(1, col + 1), Cells(1, col + 7)).HorizontalAlignment = xlCenter
     
    End If
 
col = col + 1

Next m

col = 3

For n = 3 To 10

    If .Cells(2, col) Like "*Dimanche*" Then
        .Range(Cells(1, 3), Cells(1, col)).MergeCells = True
        .Range(Cells(1, 3), Cells(1, col)).HorizontalAlignment = xlCenter
    End If
 
col = col + 1

Next n

End With

End Function

Là c'est plus que simplifié, j'aurai d'autre choses à rajouter
En vous remerciant d'avance.
Nicolas
 
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour Nicolas JACQUIN, Patrick,

S'il y a une ligne pour chaque mois sélectionnez la ligne des semaines qui la précède et exécutez :
VB:
Sub Fusionne()
Dim deb As Range, fin As Range
Set deb = Cells(ActiveCell.Row, Columns.Count).End(xlToLeft)
Set fin = Cells(ActiveCell.Row + 1, Columns.Count).End(xlToLeft)
deb.UnMerge
Range(deb, fin(0)).Merge
End Sub
A+
 

job75

XLDnaute Barbatruc
Bonjour Nicolas JACQUIN, le forum,

Ce code va bien :
VB:
Sub Test()
Agenda 2024, 5, "C1"
End Sub

Sub Agenda(an%, mois%, deb$)
Dim n%, P As Range, i%, sem%, j%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Cells.Delete 'RAZ
Range(deb) = DateSerial(an, mois, 1)
n = DateSerial(an, mois + 1, 1) - Range(deb)
Set P = Range(deb).Resize(, n)
P.DataSeries
For i = 1 To n
    P(2, i) = Application.Proper(Format(P(i), "dddd"))
    P(3, i) = Format(P(i), "dd mmmm yyyy")
Next i
For i = 1 To n
    sem = Application.IsoWeekNum(P(i))
    For j = i + 1 To n + 1
        If j > n Or Application.IsoWeekNum(P(1, j)) <> sem Then Exit For
    Next j
    P(i).Resize(, j - i).Merge 'fusionne
    P(i).HorizontalAlignment = xlCenter 'centrage
    P(i) = "Semaine " & Format(sem, "00")
    i = j - 1
Next i
Columns.AutoFit 'ajustement largeurs
End Sub
A+
 

Pièces jointes

  • Classeur(1).xlsm
    17.5 KB · Affichages: 4

job75

XLDnaute Barbatruc
Pour la boucle j il est inutile d'aller jusqu'à n + 1, utilisez simplement :
VB:
Sub Agenda(an%, mois%, deb$)
Dim n%, P As Range, i%, sem%, j%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Cells.Delete 'RAZ
Range(deb) = DateSerial(an, mois, 1)
n = DateSerial(an, mois + 1, 1) - Range(deb)
Set P = Range(deb).Resize(, n)
P.DataSeries
For i = 1 To n
    P(2, i) = Application.Proper(Format(P(i), "dddd"))
    P(3, i) = Format(P(i), "dd mmmm yyyy")
Next i
For i = 1 To n
    sem = Application.IsoWeekNum(P(i))
    For j = i + 1 To n
        If Application.IsoWeekNum(P(j)) <> sem Then Exit For
    Next j
    P(i).Resize(, j - i).Merge 'fusionne
    P(i).HorizontalAlignment = xlCenter 'centrage
    P(i) = "Semaine " & Format(sem, "00")
    i = j - 1
Next i
Columns.AutoFit 'ajustement largeurs
End Sub
 

Pièces jointes

  • Classeur(2).xlsm
    17.5 KB · Affichages: 3

TooFatBoy

XLDnaute Barbatruc
Bonjour,

Je me suis relancé dans les calendriers, mais tous sur la même ligne, mais je n'arrive pas à fusionner le n° de la dernière semaine du mois, soit dans mon cas pour le mois de mai le 31, que la fusion de cellule se termine en "AG"
J'espère que c'est assez clair.
Non, dit comme ça, pour moi ce n'est pas clair.
Mais heureusement il y a tes captures d'écran qui expliquent bien le problème. 👍


En fait, ce que je voulais dire c'est que la fusion c'est le Mal !
Et en plus ici elle semble totalement inutile. ;)
 
Dernière édition:

Discussions similaires

Membres actuellement en ligne

Statistiques des forums

Discussions
313 201
Messages
2 096 181
Membres
106 517
dernier inscrit
oubourigue