Aide VBA Excel : Inserer des lignes sous condition Résolu/Fermé

Question

Bonjour, 

Alors là, j'ai besoin de votre aide, je seche complement (vue mon faible niveau, cela m'étonne pas...)

Donc voila ma problématique.

Je voudrais dans une feuil inserer des lignes et y copier des informations provenant d'une autre feuille.

Plus précisement : 
J'appuis sur un bouton dans Feuil10
La macro va chercher dans la Feuil1 en colonne B les valeurs = B2 de la Feuil10.
Chaque fois quelle trouve les valeurs égales, elles crée une ligne dans la feuille 10 (avec mise en forme) et copie sur cette ligne en colonne A la valeur de la Feuil1 colonne A.

Je sais pas si je suis clair et si c'est réalisable, j'attends vos commentaires...
Merci d'avance,

conrade82 · Answer

Bonjour, 

Qu'y a-t-il dans Feuil10 outre le bouton et la valeur en B2 ? Pourquoi insérer une ligne ? Où voulez-vous insérer cette ligne ? Et avec quelle mise en forme ? 

Voici une ébauche: il faudrait l'adapter à votre besoin puis la tester.

Option ExplicitSub test()Dim Lastli As Integer, rCell As RangeLastli = Sheets("Feuil1").Cells(1, 1).End(xlDown).RowFor Each rCell In Sheets("Feuil1").Range("B2:B" & Lastli)    'Si valeur cellule égale B2 de Feuil10    If rCell = Sheets("Feuil10").Range("B2") Then        'Alors insérer une ligne en ligne 10 (par exemple)        With Sheets("Feuil10")            .Rows("10:10").Insert Shift:=xlDown            'Copy les données de la colonne A Feuil1 correspondantes            .Cells(10, 1).Value = Sheets("Feuil1").Cells(rCell.Row, 1).Value        End With    End IfNext rCellEnd Sub

https://www.cjoint.com/?DDxa0pZMCmr
 
Cordialement,
Conrade82

Clement79 · Answer

Merci beaucoup, c'est exactement ce que je voulais.
Par contre, quand je l'applique exactement à mon cas je rencontre une erreure " L'indice n'appartient pas..." (If rCell = Sheets("Feuil9").Range("B6") Then)

Sub LancementListing()
Dim Lastli As Integer, rCell As Range
Lastli = Sheets("Feuil2").Cells(1, 1).End(xlDown).Row
For Each rCell In Sheets("Feuil2").Range("B6:B" & Lastli)
    'Si valeur cellule égale B6 de Feuil9
    If rCell = Sheets("Feuil9").Range("B6") Then
        'Alors insérer une ligne en ligne 11 (par exemple)
        With Sheets("Feuil9")
            .Rows("11:11").Insert Shift:=xlDown
            'Copy les données de la colonne S Feuil2 correspondantes
            .Cells(10, 19).Value = Sheets("Feuil2").Cells(rCell.Row, 19).Value
        End With
    End If
Next rCell

End Sub

Je ne comprend pas d'où ça vient. De plus j'aimerais ajouter une boucle lorsque je appui sur le bouton. En effet je souhaiterais que la macro vérifie si les références ont déjà été rentrées et si oui, ne pas les remettent de nouveau.

Pour répondre à tes questions, dans le Feuil10 (en réalité Feuil9), il y a une sorte de nomenclature. Les lignes viennent s'intégrer à l'interieur. La mise en forme que je voudrais est uniquement de griser la cellule avec la valeur insérées.

J'en demande beaucoup...

Clement79 · Answer

Encore un grand merci pour ton aide.
Donc alors, le problème est résolue, j'avais bien un problème d'orthographe.
Maintenant le fichier fonctionne et intègre dans mon tableau les lignes voulues.

- La valeur B6 est fixe et ne bouge jamais. Dans la feuille 2, les 2 données peuvent évoluer.
Pour l'intégration des ligne, la macro répond à ce critère en insérant des lignes (dans un tableau déjà existant, pas de soucis de ce côté là).

- Merci pour la mise en forme, c'est parfait.

Clement79 · Answer

Sur la Feuil9, j'ai des données jusqu'à la colonne AD

Pour la Feuil1, oui je retrouve plusieurs fois la même valeur. C'est là mon problème, j'aimerais les regrouper...

conrade82 · Answer

Bonjour, 

Ne veux-tu pas créer un tableau croisé dynamique et lancer ta macro à partir de ce tableau ? Ce serait plus pratique surtout si tes données sont variables. Ne sachant pas le processus de ces données, ma solution serait de créer un TCD de la Feuil1 soit dans la même Feuille soit dans une autre feuille et ensuite tu adaptes la macro en fonction ? Peux-tu poster un extrait de ta feuil1?

Clement79 · Answer

Merci de ton aide, finallement je m'en suis sorti avec le programme ci-dessous : 

Option Explicit

Sub LancementListing1()

Dim Lastli As Integer, rCell As Range

Lastli = Sheets("Fiche").Cells(1, 19).End(xlDown).Row

'Fige l'écran pendant la suppression des lignes
Application.ScreenUpdating = False

For Each rCell In Sheets("Fiche").Range("U1:U" & Lastli)
    'Si valeur cellule égale B6 de Feuil9
    If rCell = ActiveSheet.Range("B6") Then
        'Alors insérer une ligne en ligne 12 (par exemple)
        With ActiveSheet
            .Rows("12:12").Insert Shift:=xlDown
            'Copy les données de la colonne S Feuil2 correspondantes
            With .Cells(12, 1)
              .Value = Sheets("Fiche").Cells(rCell.Row, 19).Value
              .Interior.ColorIndex = 15       'on grise la cellule matchée
            End With
            
            With .Cells(12, 2)
              .Value = Sheets("Fiche").Cells(rCell.Row, 6).Value
              .Interior.ColorIndex = 15       'on grise la cellule matchée
            End With
            
            With .Cells(12, 3)
              .Value = Sheets("Fiche").Cells(rCell.Row, 5).Value
              .Interior.ColorIndex = 15       'on grise la cellule matchée
            End With
            
            With .Cells(12, 5)
              .Value = Sheets("Fiche").Cells(rCell.Row, 12).Value
              .Interior.ColorIndex = 15       'on grise la cellule matchée
            End With
            
            With .Cells(12, 6)
              .Value = Sheets("Fiche").Cells(rCell.Row, 13).Value
              .Interior.ColorIndex = 15       'on grise la cellule matchée
            End With
            
            With .Cells(12, 7)
              .Value = Sheets("Fiche").Cells(rCell.Row, 14).Value
              .Interior.ColorIndex = 15       'on grise la cellule matchée
            End With
            
        End With
    End If
Next rCell
Call SupDoublons
Application.ScreenUpdating = True
End Sub

Sub SupDoublons()
    
    Dim Plage As Range, Cell As Range
    Dim Un As New Collection
    Dim Tableau() As Integer
    Dim x As Integer
 
    'Définit la plage de cellules pour la recherche de doublons
    Set Plage = ActiveSheet.Range("A10:A500")
 
    On Error Resume Next
    'Boucle sur les cellules de la plage cible
    For Each Cell In Plage
        'Création d'une collection de données uniques (sans doublons)
        Un.Add Cell, CStr(Cell)
 
        'Une erreur survient si l'élément existe dans la collection.
        'La procédure enregistre le numéro de ligne correspondant dans un tableau.
        If Err.Number <> 0 Then
            x = x + 1
            ReDim Preserve Tableau(1 To x)
            Tableau(x) = Cell.Row
            Err.Clear
        End If
    Next Cell
    On Error GoTo 0
 
    'On sort si aucun doublon n'a été trouvé.
    If x = 0 Then Exit Sub
 
     'Boucle sur le tableau pour supprimer les lignes contenant des doublons.
    For x = UBound(Tableau) To LBound(Tableau) Step -1
        ActiveSheet.Rows(Tableau(x)).EntireRow.Delete
    Next x
 
End Sub

conrade82 · Answer

Well done! J'avoue que je commençais à sécher pour les doublons. Parfait! Bon courage pour la suite alors! N'oublie pas changer le statut de ta question...

Aide VBA Excel : Inserer des lignes sous condition

7 réponses

Discussions similaires