Autres Déplacement d'une ligne sur une autre feuille en fonction de la valeur d'une cellule

[LeSaintKebab]

Bonjour le forum !

J'aurais besoin de votre aide pour m'aider à avancer dans ma macro

En effet, je cherche à déplacer une ligne entière située sur la feuille 1 vers la feuille 2 si la valeur en colonne F est "Mechanical".
Je devrais répéter cette manipulation avec 4 valeurs différentes mais si vous arrivez à m'éclairer sur 1, je saurais la répéter en faisant varier mes valeurs

J'ai essayé ce que je viens d'expliquer avec le bout de code suivant mais sans succès à cause d'une différence dans mes plages (je ne sais pas comment faire en sorte qu'elles concordent) :

With ws1
.Range("A1:X1").AutoFilter Field:=6, Criteria1:="=Mechanical"
.Rows("2:" & Cells.Rows.Count).SpecialCells(xlCellTypeVisible).Cut Destination:=ws2.Rows("2:" & Cells.Rows.Count)
.ShowAllData
End With

Dans ce code, ws1 est ma feuille 1 et ws2 est ma feuille 2.

Il y a peut être d'autres façons de faire cela, je suis ouvert à toutes les propositions !

Merci d'avance pour votre aide

Cordialement,
LSK

 

[LeSaintKebab]

Voici une autre tentative avec cette fois, l'ensemble des valeurs que je recherche...

dl1 = ws1.Cells(Application.Rows.Count, 1).End(xlUp).Row
dl2 = ws2.Cells(Application.Rows.Count, 1).End(xlUp).Row
dl3 = ws3.Cells(Application.Rows.Count, 1).End(xlUp).Row
dl4 = ws4.Cells(Application.Rows.Count, 1).End(xlUp).Row
For i = dl1 To 2 Step -1
If ws1.Cells(i, 6) Like "Layout and Drafting" Then
End If
If ws1.Cells(i, 6) Like "Mechanical" Then
ws1.Rows(i).Cut Destination:=ws2.Rows(dl2 + 1)
dl2 = dl2 + 1
End If
If ws1.Cells(i, 6) Like "Civil Works" Then
ws1.Rows(i).Cut Destination:=ws3.Rows(dl3 + 1)
dl3 = dl3 + 1
End If
If ws1.Cells(i, 6) Like "E&I*" Then
ws1.Rows(i).Cut Destination:=ws4.Rows(dl4 + 1)
dl4 = dl4 + 1
End If
If ws1.Range("F" & i).Value <> "Layout and Drafting" And "Mechanical" And "Civil Works" And "E&I*" Then
ws1.Rows(i).Delete
End If
Next

Le débogage m'indique une erreur de compatibilité de type dans mon dernier "if".

Merci d'avance !

Cordialement,
LSK

 

[LeSaintKebab]

Bon, j'ai finalement trouvé quelque chose qui marche donc je le pose ici si ça peut aider quelqu'un dans le futur

N'hésitez pas à me faire des remarques si ce bout de code peut être optimisé bien entendu

dl1 = ws1.Cells(Application.Rows.Count, 1).End(xlUp).Row
dl2 = ws2.Cells(Application.Rows.Count, 1).End(xlUp).Row
dl3 = ws3.Cells(Application.Rows.Count, 1).End(xlUp).Row
dl4 = ws4.Cells(Application.Rows.Count, 1).End(xlUp).Row
For i = dl1 To 2 Step -1
If ws1.Cells(i, 6) Like "Layout and Drafting" Then
ElseIf ws1.Cells(i, 6) Like "Mechanical" Then
ws1.Rows(i).Cut Destination:=ws2.Rows(dl2 + 1)
dl2 = dl2 + 1
ElseIf ws1.Cells(i, 6) Like "Civil Works" Then
ws1.Rows(i).Cut Destination:=ws3.Rows(dl3 + 1)
dl3 = dl3 + 1
ElseIf ws1.Cells(i, 6) Like "E&I*" Then
ws1.Rows(i).Cut Destination:=ws4.Rows(dl4 + 1)
dl4 = dl4 + 1
Else: ws1.Rows(i).Delete
End If
Next

Cordialement,
LSK

 

[job75]

Bonjour LeSaintKebab,

Avec 4 critères de filtrage c'est le filtre avancé qu'il faut utiliser.

Voyez le fichier joint et cette macro dans le code de la feuille "feuille 2" :

Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
Range("A2:F" & Rows.Count).Delete xlUp
With Sheets("feuille 1")
    .[Z2] = "=COUNTIF(I$1:L$1,F2)" 'critère avec NB.SI
    .[A1].CurrentRegion.AdvancedFilter xlFilterCopy, .[Z1:Z2], [A1:F1] 'filtre avancé copié
    .[Z2] = ""
End With
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Elle se déclenche quand on active la feuille.

A+

 

[job75]

Maintenant si l'on veut supprimer les lignes en "feuille 1" on utilisera ce fichier (2) et la macro :

Private Sub Worksheet_Activate()
If FilterMode Then ShowAllData 'si la feuille est filtrée
With Sheets("feuille 1").[A1].CurrentRegion
    .Cells(1).EntireColumn.Insert 'insère une colonne auxiliaire
    .Columns(0) = "=1/SIGN(COUNTIF(J$1:M$1,G1))" 'critère avec NB.SI
    .Columns(0) = .Columns(0).Value 'supprime les formules
    Union(.Columns(0), .Cells).Sort .Columns(0), xlDescending, Header:=xlYes 'tri pour regrouper et accélérer
    On Error Resume Next 'si aucune SpecialCell
    Intersect(.Columns(0).SpecialCells(xlCellTypeConstants, 1).EntireRow, .Cells).Cut Cells(Cells(Rows.Count, 6).End(xlUp).Row + 1, 1) 'couper-coller
    .Columns(0).EntireColumn.Delete 'supprime la colonne auxiliaire
End With
End Sub

Elle réalise un couper-coller.

Elle est très rapide grâce au tri réalisé sur la colonne auxiliaire.

 

[LeSaintKebab]

Bonjour job75,

Merci pour ton aide

Cordialement,
LSK