Autres Petits challenges VBA

[Cousinhub]

Bonsoir,
Un petit challenge, pour les VBAïstes endurcis
Sans boucle, remplir de A1 à A12, les mois de l'année
PS, si vous avez la solution, ne pas la mettre de suite, mais juste signaler (et me l'envoyer en MP)
Bonne soirée
Edit : Solution applicable toutes versions 🙂

 

[Cousinhub]

Hi,
Comme ça, par exemple?

Sub mois_hub()
Dim I As Integer, J As Integer
For I = 1 To 365
    If Month(I) <> Month(I - 1) Then
        J = J + 1: Cells(J, "A") = Application.GetCustomListContents(4)(J)
    End If
Next I
End Sub

 

[bsalv]

un essai

Sub Mois()
     Dim aMois(1 To 12), ptr As Integer, l, r
     x = Evaluate("text(row(A:A),""[$-fr-fr]MMMM"")")     '+1.048.000 dates du 1/1/1900 à 25/11/4770 en format "mois" !!!
     For l = 1 To UBound(x)                  'boucler les dates
          r = Application.IfError(Application.Match(x(l, 1), aMois, 0), 0)     'mois encore inconnu ???
          If r = 0 Then                      'mois est inconnu
               ptr = ptr + 1                 'incrementer pointer
               aMois(ptr) = x(l, 1)          'sauvegarder mois
          End If
          'If l > 340 Then Exit For           'maintenant pour gagner du temps, mais autrement, pour "busy doing nothing"
     Next

     Range("A1").Resize(UBound(aMois)) = Application.Transpose(aMois)
End Sub

 

[scraper]

Bonjour à vous
=TEXTE(DATE("2025";MOD(LIGNE()-1;12)*1; "01");"MMMM")

 

[patricktoulon]

bonjour
je ne sais pas pourquoi je me suis mis en tête qu'il fallait l'année aussi sinon oui dataserie ou GetCustomListContents
c'est vrai qu'on a tendance a l’oublier celui là

 

[dysorthographie]

bonjour
je ne sais pas pourquoi je me suis mis en tête qu'il fallait l'année aussi sinon oui dataserie ou GetCustomListContents
c'est vrai qu'on a tendance a l’oublier celui là

Bonjour,
Sans doute parce que c'est impicite dans la question.

Sans boucle, remplir de A1 à A12, les mois de l'année

J'ai posé la question du format au poste #2

 

[ChTi160]

Bonjour le Fil,
c'est quoi "GetCustomListContents" ?
Merci
Jean marie

 

[Cousinhub]

Bonjour le Fil,
c'est quoi "GetCustomListContents" ?
Merci
Jean marie

Hello Jean-Marie
C'est la liste des "listes personnalisées", pour les tris

Et par défaut, il y en a 4 :

La 4ème, étant la liste des mois
Bonne apm

 

[Cousinhub]

Re-,
Les membres :

 

[patricktoulon]

pour ceux que ca intéresse voila quelque exemple de base d'exploitation en vba
issu du vieux calendar
perso comme elle n'on pas de nom je me sert toujour de l'item( 1) comme nom
autrement quand je recherche une liste précise je cherche celle qui contient l'argument "titre de la fonction dans son premier item
Ajouter une liste "AddCustomListPerso"
supprimer une liste "customListdelete"
recuperer une liste "GetCustomListPerso index ou titre:="le contenu du premier item"

'-------------------------------------------
'patricktoulon
'function issue du calendar 4.1(obsolete)
'---------------------------------------------

Sub AjouterListePersonnalisee()
    Dim maListe As Variant
    maListe = Array("listdaysEN", "Monday", "Tuesday", "Wennesday", "Thursday", "Friday", "Saturday", "Sunday")
    AddCustomListPerso maListe
End Sub

Sub testX1()
    x = GetCustomListPerso(4) 'par l'index
    MsgBox Join(x, vbCrLf)
End Sub

Sub testX2()
    x = GetCustomListPerso(titre:="listdaysEN") 'par le premier item qui me sert de nom de la liste
    If IsArray(x) Then
        MsgBox Join(x, vbCrLf)
    Else
        MsgBox "liste non trouvée"
    End If
End Sub

'suppression de la liste
Sub testX3()
    customListdelete titre:="listdaysEN" 'par le premier item qui me sert de nom de la liste
End Sub


'------------------------Les fonctions------------------------

Function AddCustomListPerso(customArray)
    Application.AddCustomList ListArray:=customArray
End Function


Function GetCustomListPerso(Optional index = -1, Optional titre As String = "")
    Dim customListArray, i&
    With Application
        If index > -1 Then
            GetCustomListPerso = Application.GetCustomListContents(index)
        Else
            For i = 1 To .CustomListCount
                customListArray = Application.GetCustomListContents(i)
                If customListArray(1) = titre Then
                    GetCustomListPerso = customListArray
                End If
            Next
        End If
    End With
End Function

Function customListdelete(Optional index = -1, Optional titre As String = "")
    Dim customListArray, i&
    With Application
        If index > -1 Then
            Application.DeleteCustomList (index)
        Else
            For i = 1 To .CustomListCount
                customListArray = Application.GetCustomListContents(i)
                If customListArray(1) = titre Then
                    Application.DeleteCustomList i
                    Exit For
                End If
            Next
        End If
    End With
End Function

Patrick

 

[Staple1600]

Re

@Cousinhub
Je pensais plutôt à du chelou de ce genre 😉

Spoiler: inutile mais essentiel, non... en ces temps moroses

L'oisiveté me fait faire de ces choses dans mon VBE

Sub SortezLaCamisolePourStaple()
    Dim b() As Byte, z As Double, x(11), i%
    q = 1 + 1: qq = 2 ^ 3: qqq = Cos(0): qqqq = q ^ (qq - qqq): z = qqqq
    b = StrConv("ABCDEFGHIJKL", z)
    For i = 0 To 11
        x(i) = Asc(Chr(b(i))) - (z / 2) & "-1"
    Next
    With Cells(1).Resize(12)
        .Value = Application.Transpose(x)
        .NumberFormatLocal = "mmmm"
    End With
End Sub

 

[dysorthographie]

Sub test()
Dim Rs As Object
Set Rs = CreerRecordsetMoisMultilingue
[A1].CopyFromRecordset GetRecod(Rs, "Francais")
[B1].CopyFromRecordset GetRecod(Rs, "Chinois")
[C1].CopyFromRecordset GetRecod(Rs, "Espagnol")

End Sub
Function CreerRecordsetMoisMultilingue() As Object
    Dim rst As Object
    Dim i As Integer
    
    ' Créer un recordset dynamique
    Set rst = CreateObject("ADODB.Recordset")
    
    ' Définir les champs (langues comme noms de champs)
    With rst.Fields
        .Append "NumeroMois", 3 ' adInteger
        .Append "Francais", 202, 50 ' adVarWChar
        .Append "Anglais", 202, 50
        .Append "Chinois", 202, 50
        .Append "Espagnol", 202, 50
        .Append "Hindi", 202, 50
        .Append "Arabe", 202, 50
        .Append "Portugais", 202, 50
        .Append "Russe", 202, 50
        .Append "Japonais", 202, 50
        .Append "Allemand", 202, 50
    End With
    
    ' Ouvrir le recordset
    rst.Open
    
    ' Tableaux des mois pour chaque langue
    Dim moisFrancais As Variant
    Dim moisAnglais As Variant
    Dim moisChinois As Variant
    Dim moisEspagnol As Variant
    Dim moisHindi As Variant
    Dim moisArabe As Variant
    Dim moisPortugais As Variant
    Dim moisRusse As Variant
    Dim moisJaponais As Variant
    Dim moisAllemand As Variant
    
    moisFrancais = Array("Janvier", "Février", "Mars", "Avril", "Mai", "Juin", _
                    "Juillet", "Août", "Septembre", "Octobre", "Novembre", "Décembre")

moisAnglais = Array("January", "February", "March", "April", "May", "June", _
                    "July", "August", "September", "October", "November", "December")

moisChinois = Array("Yi yuè", "Èr yuè", "San yuè", "Sì yuè", "Wu yuè", "Liù yuè", _
                    "Qi yuè", "Ba yuè", "Jiu yuè", "Shí yuè", "Shí yi yuè", "Shí èr yuè")

moisEspagnol = Array("Enero", "Febrero", "Marzo", "Abril", "Mayo", "Junio", _
                    "Julio", "Agosto", "Septiembre", "Octubre", "Noviembre", "Diciembre")

moisHindi = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", _
                 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")

moisArabe = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", _
                 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")

moisPortugais = Array("Janeiro", "Fevereiro", "Março", "Abril", "Maio", "Junho", _
                     "Julho", "Agosto", "Setembro", "Outubro", "Novembro", "Dezembro")

moisRusse = Array("Yanvar", "Fevral", "Mart", "Aprel", "May", "Iyun", _
                 "Iyul", "Avgust", "Sentyabr", "Oktyabr", "Noyabr", "Dekabr")

moisJaponais = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", _
                    "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")

moisAllemand = Array("Januar", "Februar", "März", "April", "Mai", "Juni", _
                    "Juli", "August", "September", "Oktober", "November", "Dezember")

    
    ' Ajouter les données
    For i = 0 To 11
        rst.AddNew
        rst("NumeroMois") = i + 1
        rst("Francais") = moisFrancais(i)
        rst("Anglais") = moisAnglais(i)
        rst("Chinois") = moisChinois(i)
        rst("Espagnol") = moisEspagnol(i)
        rst("Hindi") = moisHindi(i)
        rst("Arabe") = moisArabe(i)
        rst("Portugais") = moisPortugais(i)
        rst("Russe") = moisRusse(i)
        rst("Japonais") = moisJaponais(i)
        rst("Allemand") = moisAllemand(i)
        
        rst.Update
    Next i
    
    ' Exemple d'utilisation du recordset
    rst.movefirst
   Set CreerRecordsetMoisMultilingue = rst
    
End Function
Function GetRecod(ByVal rst As Object, Langue As String) As Object
rst.movefirst
 Set GetRecod = CreateObject("ADODB.Recordset")
 With GetRecod
       .Fields.Append "Langue", 202, 50 ' adVarWChar
       .Open
       While Not rst.EOF
       .AddNew
       !Langue = rst(Langue)
       .Update
    rst.movenext
    Wend
    .movefirst
End With

 

[patricktoulon]

re
a ouais dans le genre bien bourrin c'est robert qui gagne la 🤣 🤣
ha j'adore !!

 

[dysorthographie]

re
a ouais dans le genre bien bourrin c'est robert qui gagne la 🤣 🤣
ha j'adore !!

Dans tous les cas je suis dans le top 13

 

[patricktoulon]

re
a oui il fallait oser le recordSet
mais staple1600 n'est pas en reste aussi
j'adore ça détend

 

[dysorthographie]

re
a oui il fallait oser le recordSet
mais staple1600 n'est pas en reste aussi
j'adore ça détend

Il est à deux doigts de la surchauffe 😁