Microsoft 365 Boucles Do et variables tableau

ODB

XLDnaute Nouveau
Bonjour à Tous,
J'ai du mal à mettre au point un code...
Dans le fichier excel joint, la feuille "AD" est la feuille de travail. Cette feuille donne des valeurs de poids nets ou de volume pour des références de produits alimentaires (colonne M).
Je dois faire figurer dans la colonne suivante "N" la plus petite des valeurs.
Le code utilisé est le suivant:

Sub Attributpardefaut()

Dim Racine As String

Dim wb As Workbook
Set wb = Workbooks("Catalogue_Reference.xlsm")

Dim feuille_AD As Worksheet
Set feuille_AD = wb.Worksheets("AD")
feuille_AD.Activate

Dim der_lig_AD As Long
der_lig_AD = Range("A65535").End(xlUp).Row

Dim plage, Nom, Valeurs As Range
Set plage = Range(Cells(1, 1), Cells(der_lig_AD, 14))

Dim k As Long

For i = 1 To der_lig_AD
k = i - 1
Dim tableau(90, 5) As Variant
Set Nom = plage.Cells(i + 1, 4)
Set Valeurs = plage.Cells(i + 1, 13)
tableau(k, 0) = Nom
tableau(k, 1) = Valeurs
Next i

For k = 0 To der_lig_AD
PositionTiret = InStr(1, tableau(k, 0), "-", vbTextCompare)
If PositionTiret > 0 Then
Racine = Left(tableau(k, 0), PositionTiret - 1)
tableau(k, 2) = Racine
If Left(tableau(k, 0), PositionTiret - 1) = Racine Then
If InStr(1, tableau(k, 1), "g", vbTextCompare) Then
tableau(k, 3) = Replace(tableau(k, 1), "g", "", 1, , vbTextCompare)
End If
If InStr(1, tableau(k, 1), "ml", vbTextCompare) Then
tableau(k, 3) = Replace(tableau(k, 1), "ml", "", 1, , vbTextCompare)
End If
ElseIf Left(tableau(k, 0), PositionTiret - 1) <> Racine Then
End If
ElseIf PositionTiret = 0 Then
End If
Next k

i = 1

Set plage = Range(Cells(1, 1), Cells(der_lig_AD, 14))
Set Nom = plage.Range(Cells(1, 4), Cells(der_lig_AD, 4))

Do

PositionTiret = InStr(1, Nom.Cells(i + 1, 1), "-", vbTextCompare)

If PositionTiret = 0 Then
Racine = Nom.Cells(i + 1, 1)
debut = Nom.Cells(i + 1, 1).Row
End If

debut_lignevaleurs = Nom.Cells(i + 1, 1).Offset(1, 0).Row

PositionTiret = InStr(1, Nom.Cells(i + 1, 1), "-", vbTextCompare)

If PositionTiret <> 0 Then
Do
i = i + 1
fin_lignevaleurs = Nom.Cells(i + 1, 1).Row
plage.Cells(debut, 14) = Application.Min(tableau(debut_lignevaleurs - 2, 3), tableau(fin_lignevaleurs - 2, 3))
Loop While Left(Nom.Cells(i + 1, 1), PositionTiret - 1) = Racine

ElseIf PositionTiret = 0 Then
Do
i = i + 1
fin_lignevaleurs = Nom.Cells(i + 1, 1).Row
plage.Cells(debut, 14) = Application.Min(tableau(debut_lignevaleurs - 2, 3), tableau(fin_lignevaleurs - 2, 3))
Loop While Nom.Cells(i + 1, 1) = Racine
End If

i = i + 1
Loop While fin_lignevaleurs <= der_lig_AD
End sub

Malheureusement, je n'arrive pas à aller au bout...et j'aurais bien besoin d'un coup de main pour le faire fonctionner

Merci d'avance,
 

Pièces jointes

  • Catalogue_Reference.xlsm
    451 KB · Affichages: 8

Hasco

XLDnaute Barbatruc
Repose en paix
Bonjour,

Dans le fichier joint vous trouverez un bouton lançant la macro 'FaireLeTruc'.
VB:
Sub FaireLeTruc()
    Dim Source As Variant, Resultats() As Variant, Valeurs As Variant, tmp As Variant
    Dim i As Integer, j As Integer
    With ThisWorkbook.Sheets("AD").Range("A1").CurrentRegion
        '
        ' Source dans la 13ème colonne du tableau
        Source = .Columns(13).Offset(1).Resize(.Rows.Count - 1).Value
        '
        ' préparer un tableau de résultats de même taille que le tableau source
        ReDim Resultats(1 To UBound(Source, 1), 1 To 1)
        '
        ' parcourir le tableau source
        For i = 1 To UBound(Source)
            If Not IsEmpty(Source(i, 1)) Then
                '
                ' Remplacer les g,ml et espaces dans le texte puis l'éclater en tableau
                '
                Valeurs = Split(Replace(Replace(Replace(Trim(Source(i, 1)), "g", ""), "ml", ""), " ", ""), ",")
                '
                ' Récupérer la première valeur du tableau
                tmp = CDbl(Valeurs(0))
                '
                ' puis la comparer avec les autres
                For j = 1 To UBound(Valeurs)
                    If CDbl(Valeurs(j)) < tmp Then tmp = CDbl(Valeurs(j))
                Next j
                '
                ' ne retenir que les valeurs > 0 dans le tableau de résultats final
                If tmp > 0 Then Resultats(i, 1) = tmp
            End If
        Next i
        '
        ' placer les résultats dans la 14 ème colonne du tableau
        .Columns(14).Offset(1).Resize(UBound(Resultats)) = Resultats
    End With
End Sub

Bonne journée
P.S. vous pouviez ne laissez dans votre fichier, que la feuille utile et votre macro (exemple plus léger)
 

Pièces jointes

  • Catalogue_Reference(1).xlsm
    182 KB · Affichages: 7
Dernière édition:

ODB

XLDnaute Nouveau
Merci beaucoup pour votre réponse, je regarde ça de près car pas tout à fait trivial...
J'en profite pour vous poser une question complémentaire: Dans une variable tableau contenant des valeurs dans des cellules adjacentes, comment fait on pour obtenir la plus petite valeur d'entre elles ? quelque chose comme: x=Application.Min(tableau(premiereligne,1),tableau(derniereligne,1))

Merci encore
 

Discussions similaires

Réponses
14
Affichages
622
Réponses
23
Affichages
1 K