[VBA] - Insérer le nombre adéquat de lignes et coller les valeurs

Bonjour,

Pour la finalisation d'un de mes projets, j'ai besoin de :

• Rechercher dans une feuille 1 (colonne [C]) les codes qui correspondent aux 9 premiers caractères présents dans une cellule. (=> OK)
• Ajouter en feuille 2, le nombre de ligne qui correspond aux nombre de lignes trouvées dans la feuille 1 pour le code recherché (=> OK)
• Récupérer les informations présentes en [colonne S] et les rapatrier en feuille 2 [colonne C] (=> OK)

Tout ça fonctionne pour la première ligne traitée, en revanche, si dans ma feuille 2 j'ai plus d'1 ligne (en dehors des en-têtes), alors j'ai l'erreur "Erreur définie par l'objet ou par l'application" lors de l'insertion des lignes.

Savez-vous comment résoudre ça ??

Je vous remercie de votre attention,

Je joins un document à ce post.

Bonne fin de journée !

Bonjour,

Peux-tu simplement communiquer le résultat escompté ?

Tu auras peut-être des réponses !...

Cdlt.

En effet,

Voici le document avec une nouvelle feuille "résultats".

Bonne journée !

Salut Le Drosophile,

Salut Jean-Eric,

autant éviter que q < 2, sinon 1 - 1 = bardaf!

If q < 2 Then Exit Sub

If .Cells(i, 1) <> "" Then pn.Cells(i, 1).Resize(q - 1, 1).EntireRow.Insert

Impossible pour moi d'y voir plus clair... Déso...

A+

Bonjour,

Je ne comprend pas pourquoi q = 1 alors qu'il est censé être égal au nombre de lignes à ajouter. Il compte 1 mais il y en a 4 en réalité.

Set plage = Range(Cells(2, cib), Cells(lrbdd, cib)).SpecialCells(xlCellTypeVisible) q = plage.Rows.Count

Edit : il suffit de faire comme ceci : q = plage.SpecialCells(xlCellTypeVisible).Count

Edit : ça fonctionne, je poste le code dès que j'ai finit les finiolages.

Voilà le code complet au cas où il servirait un jour ou si quelqu'un à une remarque dessus :

Set pn = Worksheets("Périmètres N2000")
Set bdd = Worksheets("BDD ""SPECIES""")
lrpn = pn.Cells(Rows.Count, 1).End(xlUp).Row
lcpn = pn.Cells(1, pn.Columns.Count).End(xlToLeft).Column

lrbdd = bdd.Cells(Rows.Count, 1).End(xlUp).Row
lcbdd = bdd.Cells(1, bdd.Columns.Count).End(xlToLeft).Column

cib = bdd.Rows("1:1").Find("NOM", LookIn:=xlValues, lookat:=xlWhole).Column

With pn
    For i = lrpn To 2 Step -1
    y = Left(.Cells(i, 2), 9)
        With bdd
            Set plage = .Range("A1:S" & lrbdd)
            plage.AutoFilter Field:=3, Criteria1:=y

            Set plage = Nothing
            Set rng = Nothing

            bdd.Activate
            Set plage = bdd.Range(.Cells(2, cib), .Cells(lrbdd, cib)).SpecialCells(xlCellTypeVisible)
                q = plage.SpecialCells(xlCellTypeVisible).Count
            Set rng = .Cells(2, cib).Resize(lrbdd) 'sitecode
            pn.Activate
            End With

            'Insérer le nombre de lignes adéquat
                If q < 1 Then
                    Exit Sub
                End If
                If .Cells(i, 1) <> "" Then
                    pn.Cells(i, 1).Resize(q, 1).EntireRow.Insert
                End If
            rng.Copy Destination:=pn.Cells(i, 3) '.Resize(q - 2)
    Next i

lrpn = pn.Cells(Rows.Count, 1).End(xlUp).Row
    For i = lrpn To 2 Step -1
        If .Cells(i - 1, 1) = "" Then
            .Range(.Cells(i, 1), .Cells(i - 1, 1)).Merge
            .Range(Cells(i, 2), Cells(i - 1, 2)).Merge
            .Range(Cells(i, 4), Cells(i - 1, 4)).Merge
            .Range(Cells(i, 5), Cells(i - 1, 5)).Merge
        End If
        If .Cells(i, 3) = "" Then
            .Cells(i, 3).EntireRow.Delete
        End If
    Next i
End With

With bdd.Cells(1, 1)
    .AutoFilter
End With

            Set plage = Nothing
            Set rng = Nothing
End Sub

J'ai dû ajouter :

        If .Cells(i, 3) = "" Then
            .Cells(i, 3).EntireRow.Delete
        End If
        

Car je ne suis pas parvenu à faire en sorte que le code ne génère pas de lignes inutiles.

Si vous avez une solution pour arrêter d'utiliser les .activate je suis preneur !

Bonne journée !