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

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

benjy555

XLDnaute Junior
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
 

Pièces jointes

Dernière édition:
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.
 
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
excel.jpg
 
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
 

Pièces jointes

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?
 
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
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

demo1.gif
 
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
 
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
 
Dernière édition:
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
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Retour