Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

L

LeSaintKebab

XLDnaute Nouveau
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
 
Solution
L
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...
Trier par date Trier par votes
L

LeSaintKebab

XLDnaute Nouveau
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
 
Vote positif 0 Vote négatif
L

LeSaintKebab

XLDnaute Nouveau
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
 
Vote positif 0 Vote négatif
Solution

job75

XLDnaute Barbatruc
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" :
VB: 
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+
 

Pièces jointes

  • Filtre avancé(1).xlsm
    18.1 KB · Affichages: 4
Vote positif 0 Vote négatif

job75

XLDnaute Barbatruc
Maintenant si l'on veut supprimer les lignes en "feuille 1" on utilisera ce fichier (2) et la macro :
VB: 
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.
 

Pièces jointes

  • Couper-coller(1).xlsm
    19.7 KB · Affichages: 8
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

G
  • Résolu(e)
Copie de données d'une feuille à une autre
Réponses
2
Affichages
206
gui22
G
P
  • Question
XL 2019 Copier des cellules d'une feuille sur une autre
Réponses
2
Affichages
228
phoceenjo
P
Y
  • Résolu(e)
XL 2013 Colorier une cellule en fonction d'une valeur
Réponses
3
Affichages
267
Yvan1
Y
  • Résolu(e)
XL 2016 Appliquer sur une sélection la couleur d'une autre cellule
Réponses
4
Affichages
135
halecs93
  • Résolu(e)
Microsoft 365 VBA - Coller la valeur d'une cellule d'une autre feuille...
Réponses
11
Affichages
509
13Hubert
  • Résolu(e)
XL 2013 (RESOLU) Automatisation de la création de feuilles en fonction des données de la cellule U13 et une feuille type
Réponses
7
Affichages
258
chaelie2015
L
  • Résolu(e)
Microsoft 365 VBA - Attribuer mise en forme en fonction de valeur cellule d'une liste
Réponses
14
Affichages
310
Laliepomm
L
Q
  • Question
XL 2019 copier une ligne en fonction de la valeur d'une cellule
Réponses
10
Affichages
670
quetzal974
Q
  • Résolu(e)
XL 2016 Créer une feuille si elle n'existe pas + Copier une plage de cellule d'une feuille à l'autre
Réponses
9
Affichages
219
_l_ours
A
  • Résolu(e)
XL 2013 valeur cellule en fonction de valeur combobox et optionbtutton
Réponses
4
Affichages
131
Appo1985
A
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…