XL 2019 Fusionner jusqu'à dernière colonne contenant

[Nicolas JACQUIN]

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 :

Mais je voudrais ça :

et voici le code à mettre dans un module

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

 

[patricktoulon]

avec un fichier ça serait mieux
cela dit avec une boucle et un union rien de plus simple

 

[Nicolas JACQUIN]

avec un fichier ça serait mieux
cela dit avec une boucle et un union rien de plus simple

tu as juste as faire un copier coller dans un fichier vierge l'ami
Rien de plus simple pour toi

 

[job75]

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 :

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+

 

[Nicolas JACQUIN]

Bonjour job75, Patrick,

je vous ai fait un pitit fichier

 

[job75]

Bonjour Nicolas JACQUIN, le forum,

Ce code va bien :

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+

 

[Nicolas JACQUIN]

Bonjour job75,
Merci pour le retour.
Nicolas

 

[job75]

Pour la boucle j il est inutile d'aller jusqu'à n + 1, utilisez simplement :

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

 

[TooFatBoy]

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.