[Résolu] Remplir une suite de plages suivant un certain ordre

  • Initiateur de la discussion Initiateur de la discussion Kim75
  • Date de début Date de début

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 !

Kim75

XLDnaute Occasionnel
Bonjour,

Je me retrouve en face d'une macro qui envoie [verticalement] une série de nombre dans des cellules rangées dans des plages [horizontales] déterminées.
VB:
For i = 1 To Sheets("Feuil3").Range("A" & Rows.Count).End(xlUp).Row
    l = 0
    c = 0
    Do Until r.Offset(l, c).Value = ""
        If l < 7 Then
            l = l + 1
        Else
            l = 0
            c = c + 1
        End If
    Loop
    r.Offset(l, c) = i
Next
J'essaye de changer l'ordre de remplissage des plages de sorte que l'envoie se fasse horizontalement (au lieu de verticalement), mais que les plages demeurent rangées horizontalement.

En fait, je n'arrive pas à définir la suite des instructions à mettre en œuvre pour aboutir au résultat recherché, ce serait sympa si quelqu'un aurait une idée là dessus, je joins un fichier illustratif.

Cordialement, Kim.
 

Pièces jointes

Bonjour Kim75.

Essayez ceci :
VB:
Sub Macro_A()
Dim i&, v(), w()
  With Feuil3.Range("A1"): v = .Resize(.Parent.Cells(.Parent.Rows.Count, .Column).End(xlUp).Row - .Row + 1, .Column).Value: End With
  With Feuil1
    .Unprotect Password:=""
    ReDim w(1 To 8, 1 To (UBound(v) - 1) \ 8 + 1)
    For i = 1 To UBound(v): w((i - 1) Mod 8 + 1, (i - 1) \ 8 + 1) = v(i, 1): Next
    With .Range("A1"): .CurrentRegion.ClearContents: .Resize(UBound(w, 1), UBound(w, 2)).Value = w: End With
    ReDim w(1 To 8, 1 To 3 * ((UBound(v) - 1) \ 24 + 1))
    For i = 1 To UBound(v): w(((i - 1) \ 3) Mod 8 + 1, (i - 1) Mod 3 + 1 + 3 * ((i - 1) \ 24)) = v(i, 1): Next
    With .Range("G24"): .CurrentRegion.ClearContents: .Resize(UBound(w, 1), UBound(w, 2)).Value = w
    End With
    .Protect Password:="", UserInterfaceOnly:=True
  End With
End Sub

Sub Macro_B()
Dim i&, v(), w()
  With Feuil3.Range("A1"): v = .Resize(.Parent.Cells(.Parent.Rows.Count, .Column).End(xlUp).Row - .Row + 1, .Column).Value: End With
  With Feuil2
    .Unprotect Password:=""
    ReDim w(1 To (UBound(v) - 1) \ 3 + 1, 1 To 3)
    For i = 1 To UBound(v): w((i - 1) \ 3 + 1, (i - 1) Mod 3 + 1) = v(i, 1): Next
    With .Range("A1"): .CurrentRegion.ClearContents: .Resize(UBound(w, 1), UBound(w, 2)).Value = w: End With
    ReDim w(1 To 8 * ((UBound(v) - 1) \ 24) + 8, 1 To 3)
    For i = 1 To UBound(v): w((i - 1) Mod 8 + 1 + 8 * ((i - 1) \ 24), ((i - 1) \ 8) Mod 3 + 1) = v(i, 1): Next
    With .Range("K5"): .CurrentRegion.ClearContents: .Resize(UBound(w, 1), UBound(w, 2)).Value = w: End With
    .Protect Password:="", UserInterfaceOnly:=True
  End With
End Sub
Bonne nuit.

ℝOGER2327
#8514


Mardi 17 Pédale 144 (Saint Dricarpe, prosélyte - fête Suprême Quarte)
21 Ventôse An CCXXV, 9,4286h - mandragore
2017-W10-6T22:37:43Z
 
Dernière édition:
Bonsoir Roger, le forum,

Merci beaucoup pour le code, ça marche super 🙂
J'avoue que c'était pas facile à décoder à la première lecture,
Mais j'ai finalement saisi la combinaison des fonctions utilisée,

Cordialement, Kim.
 
Dernière édition:
Bonsoir Roger, le forum,

Si jamais Roger a l'occasion de passer en semaine ou même courant de l'année 🙂
J'ai du mal à comprendre cette erreur dans les cas où la série de données a une certaine longueur

Cordialement, Kim.
 

Pièces jointes

Dernière édition:
Re...

J'ai effectivement été radin pour dimensionner le tableau w ! Il faut :
Code:
ReDim w(1 To 8, 1 To 3 * ((UBound(v) - 1) \ 24 + 1))
Explication :
3 * ((UBound(v) - 1) \ 24 + 1)

est la valeur maximale possible de
(i - 1) Mod 3 + 1 + 3 * ((i - 1) \ 24).

Bonne nuit.

ℝOGER2327
#8515


Mercredi 18 Pédale 144 (Saint Nosocome, carabin - fête Suprême Quarte)
22 Ventôse An CCXXV, 9,7210h - persil
2017-W10-7T23:19:50Z
 
Dernière édition:
- 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
Retour