Autres Petit defi du jour

[patricktoulon]

Bonjour a tous
Un petit défi comme ca le dimanche (et oui c'est tout moi ca )

J’ai plusieurs longueurs en nombre variable
Je cherche un algo qui me permettrait de faire des groupes de longueurs au plus proches les une des autres.
exemple
10;17.5;18;24.9;12.3;32;19;28.7;41;etc.....
ce nombre de longueurs je veux pouvoir le diviser par 3,4,ou,5,ect....groupe

ca me fera x groupes
l'addition des longueurs de ces groupes doivent être = ou tres proche

des idées ?
Patrick

 

[laurent950]

Bonjour @patricktoulon

Quelques choses comme cela ? un début d'idée

 

[patricktoulon]

Bonjour Laurent
En vba stp pas de formule
C’est pour mon algo N°2 du patchwork pour créer une autre méthode

 

[laurent950]

Bonjour @patricktoulon

pour comprendre le mécanisme avec Formule dans un premier temps
je pense que je me suis rapproché de l'écart entre le groupe 1 et Groupe 2
regarde ensuite en VBA c'est simple de faire le code

 

[patricktoulon]

Le raisonnement par formule ne me sera d'aucune utilité. Le problème que j'ai posé constitue une base, mais le contexte est bien différent.
par vba
je dois pouvoir mettre un nom a chaque item de groupe

 

[mapomme]

Bonsoir @patricktoulon😀, et à tous😉,

@patricktoulon :

Chaque groupe doit-il avoir le même d'événements ? (si oui, il faut que le nombre de groupe soit un diviseur du nombre de valeurs).

 

[job75]

Bonjour Patrick, le forum,

Voici une macro qui recherche la solution à partir de tirages aléatoires :

Sub Tirages()
Dim t, Ntirages&, N&, Ngroupes%, source, ecart, tirage&, dest(), i&, j%, mini, maxi, s, copiedest()
t = Timer
Ntirages = 10000 'modifiable
N = Application.Count(Columns(2)) 'il ne faut pas de cellules vides
Ngroupes = [E1] 'liste de validation
source = [B2].Resize(N, 2) 'tableau, plus rapide, au moins 2 éléments
ecart = 1E+99
For tirage = 1 To Ntirages
    ReDim dest(1 To N, 1 To Ngroupes) 'RAZ
    For i = 1 To N
        j = Application.RandBetween(1, Ngroupes)
        dest(i, j) = source(i, 1)
    Next i
    mini = 1E+99
    maxi = 0
    For j = 1 To Ngroupes
        s = Application.Sum(Application.Index(dest, 0, j))
        If s < mini Then mini = s
        If s > maxi Then maxi = s
    Next j
    If maxi - mini < ecart Then ecart = maxi - mini: copiedest = dest
Next tirage
'---restitution et mise en forme---
Application.ScreenUpdating = False
[F2].Resize(Rows.Count - 1, Columns.Count - 5).Delete xlUp 'RAZ
[G2].Resize(N, Ngroupes) = copiedest
With [G2].Offset(N)
    .Offset(-1, -1) = "ECART"
    .Offset(, -1) = ecart
    .Resize(, Ngroupes) = "=SUM(R2C:R[-1]C)"
    .Offset(, -1).Interior.Color = vbCyan
    .Resize(, Ngroupes).Interior.Color = vbYellow
    .Offset(, -1).Resize(, Ngroupes + 1).Borders.Weight = xlHairline
End With
With ActiveSheet.UsedRange: End With 'actualise les barres de défilement
Application.ScreenUpdating = True
MsgBox Format(Ntirages, "#,##0") & " tirages réalisés en " & Format(Timer - t, "0.00 \sec"), , "Tirages"
End Sub

Les en-têtes de colonnes des groupes sont créées par les formules en G1: P1.

A+

 

[job75]

Bonjour 🙄

Comme ceci c'est presque 2 fois plus rapide :

Sub Tirages()
Dim t, Ntirages&, N&, Ngroupes%, source, ecart, tirage&, dest(), s(), i&, v, j%, mini, maxi, copiedest()
t = Timer
Ntirages = 10000 'modifiable
N = Application.Count(Columns(2)) 'il ne faut pas de cellules vides
Ngroupes = [E1] 'liste de validation
source = [B2].Resize(N, 2) 'tableau, plus rapide, au moins 2 éléments
ecart = 1E+99
For tirage = 1 To Ntirages
    ReDim dest(1 To N, 1 To Ngroupes) 'RAZ
    ReDim s(1 To Ngroupes) 'RAZ
    For i = 1 To N
        v = source(i, 1)
        j = Application.RandBetween(1, Ngroupes)
        dest(i, j) = v
        s(j) = s(j) + v
    Next i
    mini = 1E+99: maxi = 0
    For j = 1 To Ngroupes
        v = s(j)
        If v < mini Then mini = v
        If v > maxi Then maxi = v
    Next j
    If maxi - mini < ecart Then ecart = maxi - mini: copiedest = dest
Next tirage
'---restitution et mise en forme---
Application.ScreenUpdating = False
[F2].Resize(Rows.Count - 1, Columns.Count - 5).Delete xlUp 'RAZ
[G2].Resize(N, Ngroupes) = copiedest
With [G2].Offset(N)
    .Offset(-1, -1) = "ECART"
    .Offset(, -1) = ecart
    .Resize(, Ngroupes) = "=SUM(R2C:R[-1]C)"
    .Offset(, -1).Interior.Color = vbCyan
    .Resize(, Ngroupes).Interior.Color = vbYellow
    .Offset(, -1).Resize(, Ngroupes + 1).Borders.Weight = xlHairline
End With
With ActiveSheet.UsedRange: End With 'actualise les barres de défilement
Application.ScreenUpdating = True
MsgBox Format(Ntirages, "#,##0") & " tirages réalisés en " & Format(Timer - t, "0.00 \sec"), , "Tirages"
End Sub

A+

 

[job75]

Bonjour Patrick, le forum,

Le fichier précédent peut bien sûr être utilisé pour régler au mieux le problème de ton patchwork :

https://excel-downloads.com/threads...creation-de-patchwork.20088598/#post-20704533

en y ajoutant cette macro :

Sub Import_photos()
Dim F As Worksheet, hauteur#, chemin$, fichier$, nlignes&, dest As Range, o As Object, n&, a(), Lmax#, lig&, L#, c As Range
Set F = Sheets("Groupes") 'ne pas modifier la structure de cette feuille
hauteur = 75 'hauteur des images, modifiable
chemin = ThisWorkbook.Path & "\Photos\"
fichier = Dir(chemin) '1ère photo du dossier
With Sheets("Patchwork")
    Application.ScreenUpdating = False
    .Rows("2:" & .Rows.Count).RowHeight = hauteur 'facultatif, même hauteur des lignes
    nlignes = .[C1] 'nombre de lignes de restitution
    Set dest = .[A2] '1ère cellule de restitution, à adapter
    '---RAZ---
    For Each o In .Shapes
        If o.Name Like "Pict*" Then o.Delete
    Next o
    '---récupération des images---
    While fichier <> ""
        n = n + 1
        Set o = .Pictures.Insert(chemin & fichier)
        o.Name = "Pict" & n
        o.ShapeRange.LockAspectRatio = msoTrue
        o.Height = hauteur
        ReDim Preserve a(1 To 2, 1 To n)
        a(1, n) = o.Name
        a(2, n) = o.Width
        fichier = Dir
    Wend
    '---positionnement des images---
    F.Range("A2:B" & .Rows.Count).ClearContents
    F.[A2:B2].Resize(n) = Application.Transpose(a)
    Tirages 'lance la macro
    Lmax = (Application.Max(F.Cells) + Application.Large(F.Cells, nlignes)) / 2
    For lig = 1 To nlignes
        L = 0
        For Each c In F.Cells(2, 6 + lig).Resize(n)
            If IsNumeric(CStr(c)) Then
                Set o = .Pictures("Pict" & c.Row - 1)
                o.Top = dest.Top + hauteur * (lig - 1)
                o.Left = dest.Left + L
                L = L + o.Width
            End If
        Next c
        '---ajustement largeur de la dernière image de chaque ligne---
        o.ShapeRange.LockAspectRatio = msoFalse: o.Width = o.Width + Lmax - L: o.ShapeRange.LockAspectRatio = msoTrue
    Next lig
End With
End Sub

Dans le dossier "Photos" joint les photos sont des fichiers .webp, si tu ne peux pas les ouvrir remplace-les par des fichiers .jpg ou autres.

A+

 

[patricktoulon]

bonjour @job75
je vais testé mais je suis en mode dépannage pc port w7 alors je ne peux pas garantir
mais comme je t'ai dit j'ai fini mon algo je suis même aller un peu plus loin avec le crop sur les images de fin de bande
mais comme tu a bossé je vais tester

 

[patricktoulon]

bon ben les webp c'est mort sur w 7
j'ai testé avec des jpg ca colle je comprends pas comment tu fait mais bon
je suis perplexe sachant que n'importe quelle association d'image par ligne ne peut pas avoir la même longueur
et visiblement toi oui
quand je reprend le pc en fin de semaine je testerais la c'est trop pénible avec le portable
mais je valide
je pourrait regarder ca de près dans le weekend

 

[job75]

Bien comprendre que sur chaque ligne j'ajuste la largeur de la dernière image sur Lmax.

J'ai remplacé Lmax = (Application.Max(F.Cells) par :

Lmax = (Application.Max(F.Cells) + Application.Large(F.Cells, nlignes)) / 2

ce qui permet de réduire en pourcentage les ajustements des largeurs.

 

[patricktoulon]

a ben je comprends mieux

 '---ajustement largeur de la dernière image de chaque ligne---
        If L < Lmax Then o.ShapeRange.LockAspectRatio = msoFalse: _
            o.Width = o.Width + Lmax - L: o.ShapeRange.LockAspectRatio = msoTrue

non moi je crop
je ne touche a l'aspect ratio je le préserve au contraire
mais pour cela il faut mémoriser lors de l'insertion le coeff zoom appliqué a l'image pour qu’elle fasse la hauteur des cell ,sinon c'est a peu près pareil ce que je fais sauf l'esquichage de la dernière, moi je la coupe proprement

 

[job75]

L'ajustement que je fais sur la largeur de la dernière image de chaque ligne n'est guère important (quelques %).

Car l'écart entre les longueurs des lignes est réduit au minimum grâce à la macro "Tirages".

 

[job75]

J'ai testé la solution qui consiste à préserver l'ApectRatio de la dernière image de chaque ligne.

En l'élargissant puis en la rognant par le bas.

Mais le résultat est moins satisfaisant qu'au post #9, le rognage n'est pas totalement fiable.

Bonne nuit.