XL 2016 VBA macro concatener N fois 1000 lignes

Korasgar

XLDnaute Nouveau
Bonjour la communauté,

je débute en vba et je pense m’attaquer à plus fort que moi ^^
Je souhaite, à partir d’une liste de données, concaténer les valeurs par paquets de 1000 et ce, jusqu’à la fin de la liste.
En gros si j’ai 3500 valeurs je devrais avoir 4 paquets (3 de 1000 et 1 de 500).
Une fois ceci fait, chaque ligne en fin de paquet doit être copiée à la fin du tableau en supprimant le premier caractère….

Pour l’instant ma macro est au statut d’ébauche :

VB:
Sub ConcatDonnees()

'on determine la derniere ligne du tableau
derniereligne = Range("A"&Rows.Count).End(xlUp).Row

'concatenation des donnees
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B2").Select
ActiveCell.FormulaR1C1 = "R[-1]C&"";""&RC[-1]"
Selection.AutoFill Destination:=Range("B2:B"&derniereligne + 1)

J’espère avoir été clair mais je galère depuis un moment pour automatiser ces opérations donc merci d’avance pour votre aide =)
 

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour @Korasgar :), @gbinforme ;),
Bienvenue sur XLD, @gbinforme ;),

Comme l'a dit @gbinforme, le résultat n'est guère lisible.

Voir le code suivant dans module 1:
VB:
Sub ConcatParN()
Const N = 1000
Dim t, derlig As Long, i As Long, i1 As Long, i2 As Long, k As Long, max As Long, s As String
   With Sheets("Test")
      If .FilterMode Then .ShowAllData
      derlig = .Cells(.Rows.Count, "a").End(xlUp).Row
      t = .Range("a1:a" & derlig)
      max = UBound(t) \ N
      If UBound(t) Mod N > 0 Then max = max + 1
      For k = 1 To max
         s = ""
         i1 = (k - 1) * N + 1
         i2 = i1 + N - 1: If i2 > UBound(t) Then i2 = UBound(t)
         For i = i1 To i2: s = s & ";" & t(i, 1): Next
         t(k, 1) = Mid(s, 2)
      Next k
      .Range("c1").CurrentRegion.Clear
      .Range("c1").Resize(max) = t
      Application.Goto .Range("a1"), True
   End With
End Sub

nota: je ne commente mes codes que si on me le demande (gentiment :D).
 

Pièces jointes

  • Korasgar- concatener- v1.xlsm
    55.8 KB · Affichages: 28
Dernière édition:

dysorthographie

XLDnaute Accro
bonjour,
je suis parti du code de mapomme
VB:
Option Explicit
 
Sub ConcatParN()
Dim t() As String, R As Range, I As Integer
ReDim t(0)
   With Sheets("Test")
    Set R = .Range(.Range("A1"), .Cells(.Cells.Rows.Count, "A").End(xlUp))
    For I = 1 To R.Rows.Count Step 1000
 
        t(UBound(t)) = Join(Application.Transpose(R.Range(R(I, 1).Address, R(I + 999,1).Address).Value), ";")
         ReDim Preserve t(UBound(t) + 1)
    Next
     ReDim Preserve t(UBound(t) - 1)
     While CBool(InStr(1, t(UBound(t)), ";;"))
      t(UBound(t)) = Replace(t(UBound(t)), ";;", "")
     Wend
      .Range("c1").CurrentRegion.Clear
      .Range("c1").Resize(UBound(t)+1) = Application.Transpose(t)

   End With
End Sub
 
Dernière édition:

Korasgar

XLDnaute Nouveau
bonjour,
je suis parti du code de mapomme
VB:
Option Explicit
 
Sub ConcatParN()
Dim t() As String, R As Range, I As Integer
ReDim t(0)
   With Sheets("Test")
    Set R = .Range(.Range("A1"), .Cells(.Cells.Rows.Count, "A").End(xlUp))
    For I = 1 To R.Rows.Count Step 1000
 
        t(UBound(t)) = Join(Application.Transpose(R.Range(R(I, 1).Address, R(I + 999,1).Address).Value), ";")
         ReDim Preserve t(UBound(t) + 1)
    Next
     ReDim Preserve t(UBound(t) - 1)
     While CBool(InStr(1, t(UBound(t)), ";;"))
      t(UBound(t)) = Replace(t(UBound(t)), ";;", "")
     Wend
      .Range("c1").CurrentRegion.Clear
      .Range("c1").Resize(UBound(t)+1) = Application.Transpose(t)

   End With
End Sub

Merci ça marche du feu de Dieu ^^

En fait c'est pour copier-coller les liste dans BO pour sortir des requêtes, comme j'ai besoin de faire ça 1000 par 1000 je souhaitais tout automatiser =)

Merci beaucoup en tout cas !!
 

Discussions similaires

Statistiques des forums

Discussions
311 724
Messages
2 081 936
Membres
101 844
dernier inscrit
pktla