VBA Copier une liste de valeur 1, 2 ou n fois chacune sous une seule colonne

[thomas L]

Bonjour,

Dans le cadre de mon travail, je dois analyser des tables de valeur sur excel. J'ai différent tableaux comportant plusieurs lignes dont une ligne représentant les valeurs à copier et une autre indiquant combien de fois chaque valeur doit être copier dans une même colonne (à la droite des tableaux en question). J'ai trouvé sur ce forum plusieurs discussion avec des problèmes similaire mais commençant a peine a me pencher sur les macro excel je n'ai pas réussi a utiliser les macros en question ou à les modifier pour correspondre a mes besoins.

Le nombre de valeur de de copie étant assez conséquent j’aimerai savoir si vous connaissait un moyen d'automatiser cette étape ?

Voici-ci joint un fichier excel comportant deux feuilles, une première montrant d'une manière simple le type de transformation de data dont j'ai besoin et la seconde la forme des tableaux et des datas que je dois analyser (pour avoir la position des cellules).

Merci d'avance pour votre aide et vos conseil !

 

[danielco]

Bonjour,

Clique sur la première cellule disponible, en dessous "de Colonne n" et essaie cette macro :

Sub test()
  Dim C As Range, I As Long, Pos As Integer, Lig As Long, J As Long
  Pos = Mid(Selection.Offset(-2).Value, 9, 1)
  Lig = Application.Match(Pos, [A:A], 0) + 1
  I = -1
  For Each C In Range(Cells(Lig, 2), Cells(Lig, Columns.Count).End(xlToLeft))
    For J = 1 To C.Offset(3)
      I = I + 1
        Selection.Offset(I) = C.Value
    Next J
  Next C
End Sub

Cordialement.

Daniel

 

[thomas L]

Merci pour ta réponse Daniel, La macro que tu as écrites fonctionne bien sur le fichier exemple que tu m'as renvoyé mais ne fonctionne pas sur les autres (par exemple sur le fichier ci-joint). en essayant de lancer la macro un message d'erreur, (erreur d’exécution "13" : incompatibilité de type) et le debug me renvois a la ligne "Lig = Application.Match(Pos, [A:A], 0) + 1" de ta macro.

Saurais-tu pourquoi ? j'ai essayé de comprendre fonctionnement du code mais sans succès.

 

[job75]

Bonsoir thomas L, danielco,

Voyez le fichier joint (celui du post #1) et cette macro :

Sub Copier()
Dim source, dest, i%, tablo, resu(), n&, j%, v, k&
source = Array("A3", "A11", "A19", "A27") 'à adapter
dest = Array("AQ3", "AU3", "AY3", "BC3") 'à adapter
For i = 0 To UBound(source)
    tablo = Range(source(i)).CurrentRegion.Resize(6) 'matrice, plus rapide
    ReDim resu(1 To Rows.Count, 1 To 1)
    n = 0
    For j = 2 To UBound(tablo, 2)
        v = tablo(2, j) 'valeur à recopier
        For k = 1 To tablo(6, j)
            n = n + 1
            resu(n, 1) = v
    Next k, j
    With Range(dest(i))
        If n Then .Resize(n) = resu
        .Offset(n).Resize(Rows.Count - n - .Row + 1).ClearContents 'RAZ en dessous
    End With
Next i
Range(dest(0))(0).Select
End Sub

A+

 

[danielco]

D'accord, modifie la macro comme suit :

Sub test()
  Dim C As Range, I As Long, Pos As Integer, Lig As Long, J As Long
  Lig = Application.Match(Selection.Offset(-2).Value, [A:A], 0) + 1
  I = -1
  For Each C In Range(Cells(Lig, 2), Cells(Lig, Columns.Count).End(xlToLeft))
    For J = 1 To C.Offset(3)
      I = I + 1
        Selection.Offset(I) = C.Value
    Next J
  Next C
End Sub

Daniel

 

[job75]

Avec le fichier du post #3 ci-joint il suffit d'ajouter une boucle pour traiter toutes les feuilles :

Sub Copier()
Dim source, dest, w As Worksheet, i%, tablo, resu(), n&, j%, v, k&
source = Array("A3", "A11", "A19", "A27") 'à adapter
dest = Array("AQ3", "AU3", "AY3", "BC3") 'à adapter
For Each w In Worksheets
    For i = 0 To UBound(source)
        tablo = w.Range(source(i)).CurrentRegion.Resize(6) 'matrice, plus rapide
        ReDim resu(1 To w.Rows.Count, 1 To 1)
        n = 0
        For j = 2 To UBound(tablo, 2)
            v = tablo(2, j) 'valeur à recopier
            For k = 1 To tablo(6, j)
                n = n + 1
                resu(n, 1) = v
        Next k, j
        With w.Range(dest(i))
            If n Then .Resize(n) = resu 'restitution
            .Offset(n).Resize(w.Rows.Count - n - .Row + 1).ClearContents 'RAZ en dessous
        End With
Next i, w
End Sub

 

[thomas L]

Merci à vous deux ! Les deux macros fonctionne très bien sur différent fichier excel. Ca va faire pas mal d'heures d'analyse de gagné !