Suppression ligne + remplissage onglet

Bonjour,

Je cherche via une macro a effectuer plusieurs choses qui malgré plusieurs efforts de ma part, je reste sans solution.

Je vous joins un fichier.

Dans l'onglet BD, je cherche a supprimer toutes les lignes qui ont comme valeur "TF_**" dans la colonne A

Avec ce bout de code je n'y arrive pas :

For Each CEL In .Range("A1:A" & .UsedRange.Rows.Count)

If CEL.Value Like "*TF*" Then

Rows(CEL.Row).Delete

End If
Next CEL

Le résultat recherche est d'obtenir que des cellules en colonne A ayant des valeurs de type "TI_**"

La deuxième chose que je cherche a obtenir est le remplissage de l'onglet "ModFT" de la manière suivant l'exemple ci dessous

Pour la premiere fiche

la valeur de BD.A1 = ModFT.C9 (Numéro de fiche :)

la valeur de BD.B1 = ModFT.C8 (Titre :)

la valeur de BD.E1 = ModFT.C10 (Mode opératoire:)

la valeur de BD.F1 = ModFT.C11 (Pré requis :)

la valeur de BD.G1 = ModFT.C12 (Résultat attendu :)

pour la seconde fiche

la valeur de BD.A2 = ModFT.C20 (Numéro de fiche :)

la valeur de BD.B2 = ModFT.C19 (Titre :)

la valeur de BD.E2 = ModFT.C21 (Mode opératoire:)

la valeur de BD.F2 = ModFT.C22 (Pré requis :)

la valeur de BD.G2 = ModFT.C23 (Résultat attendu :)

Bien cordialement et d'avance merci de votre aide.

Mika

Bonjour,

Voici une possibilité pour votre premier problème, en partant du bas vers le haut :

with activesheet.usedrange
    for i = .rows.count to 1 step - 1
        If .cells(i, 1).Value Like "*TF*" Then .Rows(i).Delete
    Next i
end with

Je suis persuadé que quelqu'un d'autre saura vous aider pour le second problème.

Cdlt,

Bonjour,

Votre macro est incomplète (elle ne se termine pas par End Sub). Pouvez-vous la republier ?

Merci beaucoup 3GB je cherchais a commencer par le bas et je ne savais pas comment procéder.

Voici la macro complète :

Sub test()

'Copie de l'onglet
Sheets("BD").Copy After:=Sheets(3)

With Sheets("BD (2)")

'Suppression lignes
.Rows("1:9").Delete Shift:=xlUp

'Suppression colonnes
.Columns("A:J").Delete Shift:=xlToLeft

'Libérer les volets
ActiveWindow.FreezePanes = False

'Boucle sur la colonne N°Test du début du tableau en BD jusqu'a la fin
    For I = .Rows.Count To 1 Step -1
        If .Cells(I, 1).Value Like "*TF*" Then .Rows(I).Delete
    Next I

'Tri sur la colonne K pour garder que les TI
    .Sort.SortFields.Add Key:=Range("A1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("BD (2)").Sort
        .SetRange Range("A1:A1000")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

dlg = .Range("A" & Rows.Count).End(xlUp).Row

x = Application.WorksheetFunction.RoundUp((dlg / 2), 0)

    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "FicheTestTI"

For I = 1 To x

fin = Sheets("FicheTestTI").Range("A" & Rows.Count).End(xlUp).Row

If fin = 1 Then

Sheets("ModFT").Rows("1:1").Copy
Sheets("FicheTestTI").Rows(fin).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
Sheets("ModFT").Rows("1:30").Copy Sheets("FicheTestTI").Rows(fin)

Else

Sheets("ModFT").Rows("1:30").Copy Sheets("FicheTestTI").Rows(fin + 1)

End If
Next I

'Remplissage fiche de test TI

'Recherche le code ICI

Application.DisplayAlerts = False
Sheets("FicheTestTI").Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True

End With

Application.DisplayAlerts = False
Sheets("BD (2)").Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True

End Sub

J'ai trouvé une solution pour le remplissage.