XL 2013 [Résolu] Inserer les jours dans un tableau

Lone-wolf

XLDnaute Barbatruc
Bonjour à tous :)

Concernant les tableau array, j'ai vu cet exemple

tbl(1) = "janvier"
tbl(2) = "février"
tbl(3) = "mars"

Moi j'ai modifié ceci par

VB:
Option Explicit

Sub test()
Dim i As Long, m As Long, cel As Range, dt As Date, mois, tablo(1 To 12)

    [A1:L1] = ""
    Set cel = [N1]
   
    For i = LBound(tablo, 1) To UBound(tablo, 1)
        m = m + 1
        dt = DateSerial(cel.Value, m, 1)
        tablo(i) = dt
        Cells(1, i) = Format(tablo(i), "mmmm")
        mois = UCase(Left(Cells(1, i), 1)) & LCase(Right(Cells(1, i), Len(Cells(1, i)) - 1))
        Cells(1, i) = mois
    Next i
End Sub

Maintenant, j'aimerais inserer les jours. Sachant que je ne peux pas inclure 1 to 31 dans tablo, comment fait-on pour ça?
 

Lone-wolf

XLDnaute Barbatruc
Bonjour Jean-Marie :)

Et quel approche!! :eek: Heureusement que tu as commenté le code, sinon j'aurais été complètement(là à moitié) paumé. :confused:

En tout cas très beau travail. Merci beaucoup ;)

En attendant d'avoir une réponse, j'ai fait comme ceci. Plus simpliste.

VB:
Option Explicit

Sub Calendrier()
Dim i&, j&, k&, nb_jours&, m&, cel As Range, _
dt As Date, mois, tablo(1 To 12)

    Set cel = [N1]
    [A1:L32] = ""

    Application.ScreenUpdating = False

    For i = LBound(tablo, 1) To UBound(tablo, 1)
        m = m + 1
        dt = DateSerial(cel.Value, m, 1)
        tablo(i) = dt
        Cells(1, i) = Format(tablo(i), "mmm")
        mois = UCase(Left(Cells(1, i), 1)) & LCase(Right(Cells(1, i), Len(Cells(1, i)) - 1))
        Cells(1, i) = mois
        nb_jours = Day(DateSerial(Year(dt), Month(dt) + 1, 1) - 1)
        j = 1
        For k = 1 To nb_jours
            j = j + 1
            dt = DateSerial(cel.Value, m, k)
            Cells(j, i) = dt
            If IsDate(Cells(j, i).Value) And Cells(j, i).Value = Date Then
                Cells(j, i).Interior.Color = vbRed
                Cells(j, i).Font.Color = vbWhite
            Else
                Cells(j, i).Interior.Color = xlNone
                Cells(j, i).Font.Color = vbBlack
            End If
        Next k
    Next i
End Sub

Mais je me demande si c'est possible de tranformer la boucle For k = 1 to nb_jours par For k = LBound(xxxxx, 1) To UBound(xxxxx, 1). J'ai essaié de le faire avec tbl = nb_jours, mais ça va pas.
 
Dernière édition:

ChTi160

XLDnaute Barbatruc
Re Lone-wolf
je pense que oui ais quel intérêt ?
si je reprends ton code
Dim Tablo(2,1) as Variant

Tablo(0,0)=Numéro de début exemple "1"
Tablo(1,0)=Numéro de Fin exemple "nb_jours" ex : 31
puis on boucle
VB:
For k = Lbound(Tablo,1) To Ubound(Tablo,1)
next k
la différence avec ma procèdure , c'est que l'on ne travaille pas sur des Dates mais des Chiffres de "1 à 31" !
Tu dois ensuite pour mettre en forme reconstituer la date pour traitement
VB:
dt = DateSerial(cel.Value, m, k)
A voir !!
n'hésite pas
Bonne journée
Amicalement
Jean marie
 

Lone-wolf

XLDnaute Barbatruc
Re Jean Marie

Il n'y avait pas besoin de tablo(0, 0) et tablo(1, 0). Cela grace aux démos de Jacques Boisgontier

ReDim tbl(1 To nb_jours)

For k = LBound(tbl, 1) To UBound(tbl, 1)
dt = DateSerial(cel.value, m, k)
tbl(k) = dt
Cells(k + 1, i) = tbl(k)
Next k
 

Pièces jointes

  • Calendrier-Tableau.xlsm
    24 KB · Affichages: 32

Si...

XLDnaute Barbatruc
Bonsoir
Sans ou avec Array ? Un peu moins de 370 cases : la différence de durée est négligeable.

Exemples avec le cas du passage aux couleurs par MFC :

VB:
Option Explicit
Option Base 1
Dim i As Byte, j As Byte, c As Range, Nj As Byte
Private Sub CommandButton1_Click()
  Set c = [N1]
  Application.ScreenUpdating = 0
  [A1:L32] = ""
  For i = 1 To 12
  Cells(1, i) = Format(MonthName(i), "mmmm")
  Nj = DateSerial(c, i + 1, 1) - DateSerial(c, i, 1) + 1
  For j = 2 To Nj: Cells(j, i) = DateSerial(c, i, j - 1): Next
  Next
End Sub

Private Sub CommandButton2_Click()
Dim T(32, 12)
  [A1:L32] = ""
  Set c = [N1]
  Application.ScreenUpdating = 0
  For i = 1 To 12
  T(1, i) = Format(MonthName(i), "mmmm")
  Nj = DateSerial(c, i + 1, 1) - DateSerial(c, i, 1)
  For j = 1 To Nj: T(j + 1, i) = DateSerial(c, i, j): Next
  Next
  [A1:L32] = T
End Sub


Nota : F1 pour Option Base 1 si nécessaire ;)
 

Pièces jointes

  • Calendrier.xlsm
    24.8 KB · Affichages: 31

Lone-wolf

XLDnaute Barbatruc
Bonsoir Si... :)

Et oui, rien à voir avec mon code. Quand on a la maîtrise, ce n'est qu'un jeu d'enfant. ;)
Note: juste un petit souci avec le bouton gauche, les jours ne se termine pas correctement.

calendrier.gif


Merci en tout cas pour ce bel exemple.
 

ChTi160

XLDnaute Barbatruc
Re
Tu mets Ceux ci ,pour régler le Problème
VB:
Private Sub CommandButton1_Click()
    Set c = [N1]
    Application.ScreenUpdating = false
    [A1:L32] = ""
    For i = 1 To 12
        Cells(1, i) = Format(MonthName(i), "mmmm")
                   Nj = Day(DateSerial(c, i + 1, 0)) ' Ici Changement
               For j = 1 To Nj: Cells(j + 1, i) = DateSerial(c, i, j): Next
    Next 'i
End Sub
Bonne fin de soirée
Amicalement
Jean marie
 

Discussions similaires