XL 2021 VBA pour générer une liste de valeurs comprise entre 2 valeurs

benjy555 · 30 Avril 2025

Bonjour a tous et deja merci pour votre aide 🙂

Voici l'idée : je souhaite obtenir en colonne la liste de toutes les valeurs comprises entre 2 valeurs.

En A1 il y a un type : "TOTO" en B1 il y la valeurs "1"et C 1 il y a la valeurs "10"
j'ai besoin que en D1 (peu importe, ou meme dans un nouvel onglet) la macro viennent écrire "TOTO" puis en E1 la valeurs "1" et ensuite en en D2 à nouveau "TOTO" puis en E2 : "2" , D3 "TOTO" et E3 "3" etc jusqu'à "10" en E10

Mais en A2, B2 et C2 il y a encore un nouveau type et 2 autres valeurs, par ex "TATA" "15" et "20" et il faut venir à la suite de D10 donc en D11 mettre "TATA" puis en E11 mettre "15" etc jusqu' "20"

voici l'exemple en fichier excel avec le résultat souhaité en colonne C
pour info dans mon vrai fichier j'ai plus de 14 000 ligne d'intervalles de valeurs d'ou la nécessité de la macro

merci

Dranreb · 30 Avril 2025

VB:

Option Explicit
Sub GénNbr()
   Dim TBornes(), TRésu(), L&, C%, N&, LR&
   TBornes = ActiveSheet.[A1].Resize(ActiveSheet.Cells(2 ^ 20, "A").End(xlUp).Row, 2).Value
   ReDim TRésu(1 To 25000, 1 To 1)
   For L = 1 To UBound(TBornes, 1)
      For N = TBornes(L, 1) To TBornes(L, 2)
         LR = LR + 1: TRésu(LR, 1) = N
         Next N, L
   ActiveSheet.[C1:C25000].Value = TRésu
   End Sub

Bonjour.

benjy555 · 30 Avril 2025

Dranreb à dit:
Option Explicit Sub GénNbr() Dim TBornes(), TRésu(), L&, C%, N&, LR& TBornes = ActiveSheet.[A1].Resize(ActiveSheet.Cells(2 ^ 20, "A").End(xlUp).Row, 2).Value ReDim TRésu(1 To 25000, 1 To 1) For L = 1 To UBound(TBornes, 1) For N = TBornes(L, 1) To TBornes(L, 2) LR = LR + 1: TRésu(LR, 1) = N Next N, L ActiveSheet.[C1:C25000].Value = TRésu End Sub

merci mais j'ai une erreur de syntax quand je lance cette macro cf sreenshot
est il possible de me rendre le fichier excel directement avec la macro ?
merci

Dranreb · 30 Avril 2025

Ma déclaration commence bien par "Dim TBornes()", pas "DiTBornes()". Je ne sais pas d'où ça sort !

benjy555 · 30 Avril 2025

Dranreb à dit:
Ma déclaration commence bien par "Dim TBornes()", pas "DiTBornes()". Je ne sais pas d'où ça sort !

haa mais oui bien vu...

mais bon malheureusement j'ai un autre bug plus loin au niveau de

VB:

    For N = TBornes(L, 1) To TBornes(L, 2)

benjy555 · 30 Avril 2025

Dranreb à dit:
Ma déclaration commence bien par "Dim TBornes()", pas "DiTBornes()". Je ne sais pas d'où ça sort !

en fait j'ai compris d'ou vient le pb : il manque la prise en compte du type cad le champ en colonne A qu'il faut repeter devant chaque nouvelle ligne crée => le TOTO et TATA de mon exemple

benjy555 · 30 Avril 2025

Bon malheureusement je suis bloqué car je ne sais pas modifier cette macro pour l'adapter
si quelqu'un peut m'aider ?

je remet ici le vrai fichier cette fois avec plus de 22 000 lignes car la macro ne fonctionne plus avec autant de ligne (meme en supprimant le champs en colonne A qui est le type)

idéalement il faudrait conserver et répéter le champs en A et dérouler les valeurs comprise entre colonne B et C

merci

Cousinhub · 30 Avril 2025

benjy555 à dit:
Bon malheureusement je suis bloqué car je ne sais pas modifier cette macro pour l'adapter
si quelqu'un peut m'aider ?

je remet ici le vrai fichier cette fois avec plus de 22 000 lignes car la macro ne fonctionne plus avec autant de ligne (meme en supprimant le champs en colonne A qui est le type)

idéalement il faudrait conserver et répéter le champs en A et dérouler les valeurs comprise entre colonne B et C

merci

Bonjour,
Je pense qu'Excel n'est pas l'application idoine pour obtenir ce que tu veux.
Le traitement de ces données renvoie 16 392 579 lignes, soit à peu près 16 la capacité...
Autre option?

Dranreb · 30 Avril 2025

Effectivement, le nombre de lignes est limité à 2^20 soit 1048576, largement dépassées par les 16391984 requis d'après la liste des bornes spécifiées, même en ignorant celles qui ne sont pas numériques …

Dranreb · 30 Avril 2025

Le code quand même, au cas où vous parviendriez à limiter ça à environ 22000 lignes :

VB:

Option Explicit
Sub GénNbr()
   Dim TDonn(), TRésu(), L&, N&, LR&
   TDonn = ActiveSheet.[A1].Resize(ActiveSheet.Cells(2 ^ 20, "B").End(xlUp).Row, 3).Value
   For L = 1 To UBound(TDonn, 1)
      If VarType(TDonn(L, 2)) = vbDouble And VarType(TDonn(L, 3)) = vbDouble Then
         If TDonn(L, 3) >= TDonn(L, 2) Then LR = LR + TDonn(L, 3) - TDonn(L, 2) + 1
         End If
      Next L
   ReDim TRésu(1 To LR, 1 To 1)
   LR = 0
   For L = 1 To UBound(TDonn, 1)
      If VarType(TDonn(L, 2)) = vbDouble And VarType(TDonn(L, 3)) = vbDouble Then
         For N = TDonn(L, 2) To TDonn(L, 3)
            LR = LR + 1: TRésu(LR, 1) = TDonn(L, 1): TRésu(LR, 1) = N
            Next N: End If: Next L
   ActiveSheet.[D:F].ClearContents
   ActiveSheet.[D1].Resize(LR, 3).Value = TRésu
   End Sub

patricktoulon · 30 Avril 2025

bonjour

VB:

Sub test()
    createtable [a1:c3].Value
End Sub

Sub createtable(tb As Variant)
    Dim t(), InD&, Lig&, A&
    For InD = 1 To UBound(tb)
        For Lig = tb(InD, 2) To tb(InD, 3)
            A = A + 1: ReDim Preserve t(1 To 2, 1 To A): t(1, A) = tb(InD, 1): t(2, A) = Lig
        Next
    Next
    Feuil1.[d1].Resize(A, 2) = Application.Transpose(t)

End Sub

Cousinhub · 30 Avril 2025

patricktoulon à dit:

bonjour

VB:

Sub test()
    createtable [a1:c3].Value
End Sub

Sub createtable(tb As Variant)
    Dim t(), InD&, Lig&, A&
    For InD = 1 To UBound(tb)
        For Lig = tb(InD, 2) To tb(InD, 3)
            A = A + 1: ReDim Preserve t(1 To 2, 1 To A): t(1, A) = tb(InD, 1): t(2, A) = Lig
        Next
    Next
    Feuil1.[d1].Resize(A, 2) = Application.Transpose(t)

End Sub

Regarde la pièce jointe 1217220

Euh,
Regarde le fil, il y a plus de 16 millions de lignes au final, et les colonnes B et C ne sont pas forcément numériques....
Bonne journée

benjy555 · 5 Mai 2025

Dranreb à dit:

Le code quand même, au cas où vous parviendriez à limiter ça à environ 22000 lignes :

VB:

Option Explicit
Sub GénNbr()
   Dim TDonn(), TRésu(), L&, N&, LR&
   TDonn = ActiveSheet.[A1].Resize(ActiveSheet.Cells(2 ^ 20, "B").End(xlUp).Row, 3).Value
   For L = 1 To UBound(TDonn, 1)
      If VarType(TDonn(L, 2)) = vbDouble And VarType(TDonn(L, 3)) = vbDouble Then
         If TDonn(L, 3) >= TDonn(L, 2) Then LR = LR + TDonn(L, 3) - TDonn(L, 2) + 1
         End If
      Next L
   ReDim TRésu(1 To LR, 1 To 1)
   LR = 0
   For L = 1 To UBound(TDonn, 1)
      If VarType(TDonn(L, 2)) = vbDouble And VarType(TDonn(L, 3)) = vbDouble Then
         For N = TDonn(L, 2) To TDonn(L, 3)
            LR = LR + 1: TRésu(LR, 1) = TDonn(L, 1): TRésu(LR, 1) = N
            Next N: End If: Next L
   ActiveSheet.[D:F].ClearContents
   ActiveSheet.[D1].Resize(LR, 3).Value = TRésu
   End Sub

bonjour et merci bcp
desolé du retour tardif

je peux proceder en plusieurs fois et decouper ma donnée source donc cela ira tres bien merci

le pb ici c'est que le type qui est en colonne A n'apparait plus dans le résultat et c'est les infos de la colonne B qui se répètent 3 fois en D, E et F

merci

benjy555 · 5 Mai 2025

patricktoulon à dit:

bonjour

VB:

Sub test()
    createtable [a1:c3].Value
End Sub

Sub createtable(tb As Variant)
    Dim t(), InD&, Lig&, A&
    For InD = 1 To UBound(tb)
        For Lig = tb(InD, 2) To tb(InD, 3)
            A = A + 1: ReDim Preserve t(1 To 2, 1 To A): t(1, A) = tb(InD, 1): t(2, A) = Lig
        Next
    Next
    Feuil1.[d1].Resize(A, 2) = Application.Transpose(t)

End Sub

Regarde la pièce jointe 1217220

merci beaucoup pour tout ça

malheureusement de mon coté la macro ne reagit pas du tout ainsi !

j'ai ajusté avec mon nombre de ligne :

VB:

createtable [a1:c20543].Value

mais le pb idem que pour l'autre macro c'est que le type qui est en colonne A n'apparait plus dans le résultat et c'est les infos de la colonne B qui se répètent 3 fois en D, E et F

merci

benjy555 · 5 Mai 2025

voici ce que j'obtiens dans les 2 cas avec ces macros :

XL 2021 VBA pour générer une liste de valeurs comprise entre 2 valeurs

benjy555

XLDnaute Junior

Pièces jointes

Dranreb

XLDnaute Barbatruc

benjy555

XLDnaute Junior

Dranreb

XLDnaute Barbatruc

benjy555

XLDnaute Junior

benjy555

XLDnaute Junior

benjy555

XLDnaute Junior

Pièces jointes

Cousinhub

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Cousinhub

XLDnaute Barbatruc

benjy555

XLDnaute Junior

benjy555

XLDnaute Junior

benjy555

XLDnaute Junior

Discussions similaires

XL 2021 VBA pour générer une liste de valeurs comprise entre 2 valeurs

XLDnaute Junior

Pièces jointes

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Junior

XLDnaute Junior

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Junior

XLDnaute Junior

Discussions similaires

Privacy & Transparency

Privacy & Transparency