XL 2016 VBA macro concatener N fois 1000 lignes

[Korasgar]

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 :

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 =)

 

[gbinforme]

Bonjour,
Grouper 1000 cellules ne me parait pas très réaliste car ce ne sera pas affichable mais ton objectif n'est pas clair et ton code ne correspond guère à ton objectif.

 

[mapomme]

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:

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 ).

 

[dysorthographie]

bonjour,
je suis parti du code de mapomme

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

 

[Korasgar]

Merci de vos réponses je vais tester et je reviens vers vous !

 

[gbinforme]

Bonsoir,

@dysorthographie
Très belle idée réalisée, à la fois simple et efficace.

Comme le résultat ne peux être vu que dans la barre de formule si la colonne n'est pas trop large, je n'en vois vraiment pas l'utilité pratique mais Korasgar nous expliquera.

​

 

[Korasgar]

bonjour,
je suis parti du code de mapomme

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