Copier/Coller x fois

[thierry.bayard]

Bonjour,

J'ai un problème très simple mais difficile à décrire, d'où la présence d'un fichier exemple.

En quelques mots :
- J'ai 2 listes distinctes (1 liste de comptes, 1 liste d'UF)
- Je veux obtenir un tableau avec 2 colonnes (Comptes et UF) qui reprenne chaque possibilité compte / UF. Ainsi le nombre de ligne du tableau correspond au nombre de comptes multiplié par le nombre d'UF. (C'est plus facilement compréhensible avec le fichier joint).
- Le nombre de comptes et d'UFs est variable.

J'ai "bidouillé" un morceau de code qui fonctionne mais devient très très long lorsque le nombre de comptes et d'UF augmente. :

Sub Macro1()
'
' Macro1 Macro
'
    Dim compteur

    Application.ScreenUpdating = False
    
    Range("F2:G200").ClearContents

    Application.Goto Reference:="Liste_cpte"
    Selection.Copy
    
    If Range("Nb_UF").Value = 1 Then
        Range("F2").Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        Else
        Range("F2").Select
        ActiveSheet.Paste
        For compteur = 1 To Range("Nb_UF").Value - 1
            Range("F2").End(xlDown).Offset(1, 0).PasteSpecial
        Next
        Application.CutCopyMode = False
    End If
    
    Range("Liste_UF").Copy
    Range("G2").PasteSpecial
    Application.CutCopyMode = False
    
    While ActiveCell.Offset(1, -1).Value <> ""
        ActiveCell.Offset(1, 0).Select
        If ActiveCell.Offset(0, -1).Value = Range("F2").Value Then
            Else
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            ActiveCell.Offset(-1, 0).Copy
            ActiveCell.PasteSpecial
            Application.CutCopyMode = False
        End If
    Wend
   
    Application.ScreenUpdating = True
   
End Sub

Voyez-vous une solution pour améliorer cela ?

Merci d'avance pour votre aide.

Thierry

 

[Robert]

Re : Copier/Coller x fois

Bonjour Thierry, bonjour le forum,

Essaie comme ça :

Sub Macro1()
Dim ad As Range 'déclare la variable ad (Anciennes Données)
Dim o As Object 'déclare la variable o (Onglet)
Dim plc As Range 'déclare la variable plc (PLage des Comptes)
Dim plu As Range 'déclare la variable plu (PLage des Uf)
Dim dl As Long 'déclare la variable dl (dernière Ligne)
Dim cc As Range 'déclare la variable cc (Cellule des Compte)
Dim cu As Range 'déclare la variable cu (Cellule de Uf)
Dim dest As Range 'déclare la variable dest (cellule de DESTination)

Set o = Sheets("Feuil1") 'définit l'onglet o
Set ad = o.Range("F1").CurrentRegion 'définit la plage ad
If ad.Rows.Count > 1 Then 'condition : si le nombre de ligne de la plage ad est supérieur à 1
    Set ad = ad.Offset(1, 1).Resize(ad.Rows.Count - 1, ad.Columns.Count - 1) 'redéfinit la plage ad (sans les étiquettes)
    ad.ClearContents 'efface la plage ad
End If 'fin de la condition
dl = o.Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne éditée dl de la colonne 1 (=A)
Set plc = o.Range("A2:A" & dl) 'définit la plage plc
dl = o.Cells(Application.Rows.Count, 2).End(xlUp).Row 'définit la dernière ligne éditée dl de la colonne 2 (=B)
Set plu = o.Range("B2:B" & dl) 'définit la plage plu
For Each cu In plu 'boucle 1 sur toutes les cellules cu de la plage plu
    For Each cc In plc 'boucle 1 sur toutes les cellules cc de la plage plc
        Set dest = Cells(Application.Rows.Count, 6).End(xlUp).Offset(1, 0) 'définit la cellule de destination dest
        dest.Value = cc.Value 'recupère la valeur de la cellule de compte cc
        dest.Offset(0, 1).Value = cu.Value 'recupère la valeur de la cellule de uf cu
    Next cc 'prochaine cellule de la boucle 2
Next cu 'prochaine cellule de la boucle 1
End Sub

 

[pierrejean]

Re : Copier/Coller x fois

Bonjour Thierry

Teste ceci

Edit : Salut Robert

 

[Robert]

Re : Copier/Coller x fois

Bonjour Thierry, PierreJean, bonjour le forum,

Ta proposition, PierreJean, est incontestablement mieux. C'est bien plus rapide en passant par des tableaux...

 

[pierrejean]

Re : Copier/Coller x fois

Re

Wouaouh !!!
Des compliments de Robert !!!
Je bois du petit lait

 

[thierry.bayard]

Re : Copier/Coller x fois

Bonsoir Robert, Bonsoir PierreJean,

Je n'ai pu me reconnecter que maintenant. Je n'ai pas le courage de tester vos propositions ce soir. Je le fais dès demain matin et vous tiens au courant.

Merci beaucoup !!

 

[thierry.bayard]

Re : Copier/Coller x fois

PierreJean,

Ta solution me semble très intéressante. Je vais tenter de l'appliquer à mon fichier complet.

Bonne journée

 

[thierry.bayard]

Re : Copier/Coller x fois

J'oubliais de poser ma petite question subsidiaire : a quoi sert le "Option base 1" en début de module ?

 

[pierrejean]

Re : Copier/Coller x fois

Re

L'Option base 1 sert a spécifier que les tableaux ont pour origine 1 (et non zéro comme en standard)

 

[thierry.bayard]

Re : Copier/Coller x fois

OK, je ne maitrise pas encore ces subtilités... mais je ne l'avais pas mis au démarrage et ca ne fonctionnait pas. Maintenant tout est nickel sauf une petite chose : la macro ne fonctionne pas si on a un seul compte...
J'essaie de trouver une solution...

 

[thierry.bayard]

Re : Copier/Coller x fois

Aie Aie Aie !!! J'enrage !!!
Je ne m'en sors pas. N'étant pas expert en VBA, j'essaie des solutions très manuelles mais je bloque à chaque ligne :

Option Base 1
Sub test()
Dim w
Dim x
Dim y
Dim z
Range("F2:G" & Rows.Count).ClearContents
Tablo1 = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
Tablo2 = Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
If Range("A3") = "" Then
    y = 1
    w = 1
    Else
    y = UBound(Tablo1)
    w = LBound(Tablo1)
End If
If Range("B3") = "" Then
    z = 1
    x = 1
    Else
    z = UBound(Tablo2)
    x = LBound(Tablo2)
End If
ReDim tablo3(y * z, 2)
lig = 1
For n = x To z
  For m = w To y
    tablo3(lig, 2) = Tablo2(n, 1)
    tablo3(lig, 1) = Tablo1(m, 1)
    lig = lig + 1
  Next
Next
Range("F2").Resize(UBound(tablo3, 1), UBound(tablo3, 2)) = tablo3
End Sub

Je crois que je vais encore avoir besoin de votre aide...

 

[thierry.bayard]

Re : Copier/Coller x fois

Ca y est, j'y suis arrivé. Ce n'est certainement pas la solution la plus élégante mais ça fonctionne :

Option Base 1
Sub test2()

Range("F2:G" & Rows.Count).ClearContents

If Range("A3") = "" Then
    tablo1 = Range("A2")
    tablo2 = Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)

    ReDim tablo3(UBound(tablo2), 2)
    lig = 1
    For n = LBound(tablo2) To UBound(tablo2)
        tablo3(lig, 2) = tablo2(n, 1)
        tablo3(lig, 1) = Range("A2").Value
        lig = lig + 1
    Next
    
    Else
    
    tablo1 = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
    tablo2 = Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)

    ReDim tablo3(UBound(tablo1) * UBound(tablo2), 2)
    lig = 1
    For n = LBound(tablo2) To UBound(tablo2)
    For m = LBound(tablo1) To UBound(tablo1)
        tablo3(lig, 2) = tablo2(n, 1)
        tablo3(lig, 1) = tablo1(m, 1)
        lig = lig + 1
    Next
    Next
End If

Range("F2").Resize(UBound(tablo3, 1), UBound(tablo3, 2)) = tablo3

End Sub

Merci beaucoup pour votre aide : grace à vous le temps d'exécution de ma macro complète est passée de 20 minutes à 3min30 !!

 

[pierrejean]

Re : Copier/Coller x fois

Re

Version acceptant 1 seul compte
S.T.P ne pas demander pour 1 seul compte et un seul UF (a la mimine cela devrait se faire sans Pb)

 

[thierry.bayard]

Re : Copier/Coller x fois

Merci Pierrejean,

Nous sommes globalement parvenu à la même solution pour la version avec un seul compte (le cas de figure ne peut pas se présenter avec une seule UF (ouf !!)).
En fait, j'étais obligé de trouver une solution autre que "à la mimine" pour le cas avec un seul compte car cet extrait de macro s'intègre dans un ensemble qui enchaine une soixantaine de traitements (il s'agit d'un classeur me permettant de réaliser l'ensemble de ma comptabilité analytique).
Merci encore pour ton aide.

Thierry