Copier lignes d'un range selon conditions

Question

N’ayant pas trouvé une solution à mon problème, je m’adresse aux experts du Forum afin d’apporter une aide précieuse. La feuille source, se nomme "Elevage". La feuille destination, se nomme "Croisement". Ma demande concerne la copie de certaines données en respectant certaines consignes. La demande se présente en deux étapes : La première étape : Copier à partir de la feuille "Elevage" chaque ligne du range ("N2 :P" & dernière Ligne colonne "N") pour les coller dans la feuille "Croisement", à partir de la cellule "B2", de manière à copier chaque ligne tous les 3 lignes, voir les résultats dans la feuille "Résultat". La 2e étape : Copier à partir de la feuille "Elevage" chaque ligne du range ("R2 :T" & dernière Ligne colonne "R") pour les coller dans la feuille "Croisement", à partir de la cellule "F2", de manière à répéter chaque ligne 3 fois, voir résultats dans la feuille "Résultat". J’ai réduit mes données pour ne pas charger le fichier joint, toutefois, mon fichier contient un certain nombre de lignes, l’utilisation de tableau serait appréciable pour exécuter le code plus rapidement. Puis-je me permettre de vous demander une solution en vba car j’aurais besoin pour une utilisation ultérieure dans d’autres feuilles. Je reste à votre disposition si besoin d’autres informations supplémentaires. Je vous remercie d’avance pour vos propositions...

xorsankukai · Accepted Answer

Bonjour Harzer , saboh12617 , le forum, A partir du travail fourni par saboh12617 ( ) et en attendant son correctif, voici un essai.... Cordialement...

saboh12617 · Accepted Answer

Veuillez trouver ci-après la macro de curulis où j’ai pu très simplement implémenter la fonction de “choix de feuille” que vous aviez demandé. On y voit l’intéret d’un code bien construit puisqu’il m’a suffit de remplacer 1 mot-clé dans son code pour ajouter la petite fonction de choix de feuille. Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) ' Dim tTab(), tTab1, tTab2 Dim iRow% ' With ChooseSheet .Cells.Delete .Range("A1").Resize(1, 8).Value = Array("Cages", "Femelles", "Père", "Mère", "", "Mâles", "Père", "Mère") ' tTab1 = Range("N2:P" & Range("N" & Rows.Count).End(xlUp).Row).Value tTab = Range("AAA1").Resize(UBound(tTab1, 1) * 3, 5) iRow = 1 For x = 1 To UBound(tTab1, 1) For y = 1 To 5 If y &gt; 1 And y &lt; 5 Then tTab(iRow, y) = tTab1(x, y - 1) Else tTab(iRow, y) = IIf(y = 1, "Cage " & x, x) End If Next iRow = iRow + 3 Next .Range("A2").Resize(UBound(tTab, 1), 5).Value = tTab ' tTab1 = Range("R2:T" & Range("R" & Rows.Count).End(xlUp).Row).Value tTab = Range("AAA1").Resize(UBound(tTab1, 1) * 3, 4).Value iRow = 0 For x = 1 To UBound(tTab1, 1) For y = 1 To 3 iRow = iRow + 1 If y = 1 Then tTab(iRow, 1) = x For Z = 2 To 4 tTab(iRow, Z) = tTab1(x, Z - 1) Next Next Next .Range("E2").Resize(UBound(tTab, 1), 4).Value = tTab .Activate End With ' End Sub Private Function ChooseSheet() As Worksheet Dim sheetName As String sheetName = Application.InputBox("Entrez le nom de la feuille d'export ci-dessous :", "Export", Type:=2) Dim wkSheet As Worksheet, sht As Variant For Each sht In ThisWorkbook.Worksheets If sht.Name = sheetName Then Set wkSheet = sht Next sht If wkSheet Is Nothing Then Set wkSheet = ThisWorkbook.Worksheets.Add wkSheet.Name = sheetName End If Set ChooseSheet = wkSheet End Function...

saboh12617 · Answer

Cette macro vous convient-elle ? Public Sub DupliquerLignes() Dim Elevage As Worksheet Set Elevage = ThisWorkbook.Worksheets("Elevage") Dim mesVaches As Object Set mesVaches = CreateObject("System.Collections.ArrayList") Dim ligneIni As Long, ligneFin As Long ligneIni = 2 ligneFin = Elevage.Range("N" & ligneIni).End(xlDown).Row Dim i As Long For i = ligneIni To ligneFin With Application.WorksheetFunction mesVaches.Add Array( _ .Transpose(.Transpose(Elevage.Cells(i, 14).Resize(1, 3).Value2)), _ .Transpose(.Transpose(Elevage.Cells(i, 18).Resize(1, 3).Value2)) _ ) End With Next i Dim Croisement As Worksheet Set Croisement = ThisWorkbook.Worksheets("Croisement") Dim j As Byte For i = 0 To mesVaches.Count - 1 Croisement.Cells(2 + 3 * i, 1).Value2 = "Cage " & i + 1 Croisement.Cells(2 + 3 * i, 2).Resize(1, 3).Value2 = mesVaches(i)(0) For j = 0 To 2 Croisement.Cells(2 + 3 * i + j, 6).Resize(1, 3).Value2 = mesVaches(i)(1) Next j Next i End Sub Il y a quelques optimisations possibles, mais si cela convient ça me semble un bon début. Je n'ai pas recopié les en-tetes ni ajouté de suppression des données avant réécriture, mais c’est possible si besoin...

saboh12617 · Answer

Merci pour votre retour.
Oui effectivement j’ai noté des lignes vides et je ne comprends pas, je pensais que c’était un problème de copie. Vous souhaitez qu’elles soient retranscrites avec une première ligne “blanche” (colonnes B:D) en face de la cage (càd. comme sur votre résultat) ?

Pour les en-tetes, je dirai que cela dépend de l’objectif final :

Si vous utilisez toujours cette meme feuille, je pense que vous pouvez les coller manuellement. C’est une manip unique.

Si vous voulez que la macro crée une nouvelle feuille, alors merci de le préciser, et auquel cas, oui, il est utile que la macro copie les en-tete.

Enfin vous parliez de tableaux, je n’ai pas compris. Si vous pouviez mettre à jour l’exemple sur ce point.

Et, voulez-vous que la colonne E reprennent les numéros de cage de la colonne A ?

saboh12617 · Answer

D'accord. Ci-après le code adapté pour répondre aux critères mentionnés : Public Sub DupliquerLignes() Application.ScreenUpdating = False Dim Elevage As Worksheet Set Elevage = ThisWorkbook.Worksheets("Elevage") Dim mesVaches As Object Set mesVaches = CreateObject("System.Collections.ArrayList") Dim ligneIni As Long, ligneFin As Long ligneIni = 2 ligneFin = Elevage.Range("N" & ligneIni).End(xlDown).Row Dim i As Long For i = ligneIni To ligneFin With Application.WorksheetFunction mesVaches.Add Array( _ .Transpose(.Transpose(Elevage.Cells(i, 14).Resize(1, 3).Value2)), _ .Transpose(.Transpose(Elevage.Cells(i, 18).Resize(1, 3).Value2)) _ ) End With Next i Dim outSheet As Worksheet Set outSheet = ChooseSheet With outSheet.Range("A1:H1") Range(.Cells, outSheet.Cells(outSheet.Rows.Count, 8)).ClearContents .Value2 = Array("Cages", "Femelle", "Père", "Mère", "", "Mâles", "Père", "Mère") .Font.Bold = True End With Dim j As Byte For i = 0 To mesVaches.Count - 1 outSheet.Cells(2 + 3 * i, 1).Value2 = "Cage " & i + 1 outSheet.Cells(2 + 3 * i, 2).Resize(1, 3).Value2 = mesVaches(i)(0) outSheet.Cells(2 + 3 * i, 5).Value2 = i + 1 For j = 0 To 2 outSheet.Cells(2 + 3 * i + j, 6).Resize(1, 3).Value2 = mesVaches(i)(1) Next j Next i outSheet.Range("A:H").Columns.AutoFit Application.ScreenUpdating = True End Sub Private Function ChooseSheet() As Worksheet Dim sheetName As String sheetName = Application.InputBox("Entrez le nom de la feuille d'export ci-dessous :", "Export", Type:=2) Dim wkSheet As Worksheet, sht As Variant For Each sht In ThisWorkbook.Worksheets If sht.Name = sheetName Then Set wkSheet = sht Next sht If wkSheet Is Nothing Then Set wkSheet = ThisWorkbook.Worksheets.Add wkSheet.Name = sheetName End If Set ChooseSheet = wkSheet End Function Bon weekend...

Curulis · Answer

Salut Harzer,
Salut L'équipe,

Bien le bonjour Xorsankukai !

Pour le plaisir du code!
Macro à démarrer via un double-clic sur la feuille 'Elevage'.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tTab(), tTab1, tTab2
Dim iRow%
'
With Worksheets("Croisement")
    .Cells.Delete
    .Range("A1").Resize(1, 8).Value = Array("Cages", "Femelles", "Père", "Mère", "", "Mâles", "Père", "Mère")
    '
    tTab1 = Range("N2:P" & Range("N" & Rows.Count).End(xlUp).Row).Value
    tTab = Range("AAA1").Resize(UBound(tTab1, 1) * 3, 5)
    iRow = 1
    For x = 1 To UBound(tTab1, 1)
        For y = 1 To 5
            If y > 1 And y < 5 Then
                tTab(iRow, y) = tTab1(x, y - 1)
            Else
                tTab(iRow, y) = IIf(y = 1, "Cage " & x, x)
            End If
        Next
        iRow = iRow + 3
    Next
    .Range("A2").Resize(UBound(tTab, 1), 5).Value = tTab
    '
    tTab1 = Range("R2:T" & Range("R" & Rows.Count).End(xlUp).Row).Value
    tTab = Range("AAA1").Resize(UBound(tTab1, 1) * 3, 4).Value
    iRow = 0
    For x = 1 To UBound(tTab1, 1)
        For y = 1 To 3
            iRow = iRow + 1
            If y = 1 Then tTab(iRow, 1) = x
            For Z = 2 To 4
                tTab(iRow, Z) = tTab1(x, Z - 1)
            Next
        Next
    Next
    .Range("E2").Resize(UBound(tTab, 1), 4).Value = tTab
    .Activate
End With
'
End Sub

15cages.xlsm (23.31 Ko)

A+

saboh12617 · Answer

Ne vous inquiétez pas je n’ai absolument aucun problème avec les autres solutions proposées bien au contraire ! Nous sommes sur un forum, pour moi c’est fait pour collaborer. Effectivement j’avais complètement zappé l’histoire des lignes vides je m’en excuse. Il fallait simplement changer au début de la macro (ligne 11) ligneFin = Elevage.Range("N" & ligneIni).End(xlDown).Row Par ligneFin = Elevage.Range("R" & ligneIni).End(xlDown).Row Pour aller chercher la dernière ligne de la colonne R et non N. Au niveau de la vitesse d’exécution la proposition de curulis l’emporte haut la main sur de plus grands échantillons (1000 lignes par exemple). Quand j’évoquais les optimisations possibles il y avait notamment celle qu’il a utilisé de tout rentrer dans un grand tableau, inséré dans Excel en 1 étape. Les macros perdent en général le plus de temps à lire/écrire dans le classeur qu’à proprement calculer. Hors ma proposition vous faisait, pour une raison de “simplicité de codage” une instruction d’écrite ligne par ligne du tableau. Donc pour résumer plus votre tableau s’allonge et moins ma macro sera performante là où celle de curulis suivra en théorie une augmentation très faible du temps d’exécution. Bravo à lui ! Bonne journée...