XL 2019 copier une colonne si

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

Jerry590

XLDnaute Nouveau
Bonjour à tous,
Je cherche à copier des lignes en fonction deux critères (en quelque sorte un "copie si ") dans un autre onglet "template"et les placer à la suite dans l’onglet "destination", mais je n'arrive pas à l'écrire en VBA.
exemple:
-j'aimerais copier les lignes si [la colonne "Division d'affectation" ]= "Transport " & [la colonne "Société d'affectation"]= "a"
Alors copier la ligne entière sur onglet "destination".
-ensuite j'aimerais copier les lignes si [la colonne "Division d'affectation" ]= "Holding" & [la colonne "Société d'affectation"]= "b"
-enfin j'aimerais copier les lignes si [la colonne "Division d'affectation" ]= "Autres" & [la colonne "Société d'affectation"]= "dacom"
Alors copier la ligne entière sur onglet "destination" à partir de la dernière ligne du fichier.
Je suis bloqué dessus n'arrive pas à le faire.
Merci pour votre compréhension.
 

Pièces jointes

Solution
avec cette modif de code

en cas d'erreur.. on continue..
ca ne regle pas le problème d'adresse manquante.. et ca ignore l'erreur, quelque soit son origine...
c'est un peu comme quand t'es en voiture.. si plus de frein. et bah.. tu continues quand meme.. advienne que pourra..

VB:
Sub Transfert2()
Dim ncol%, source As Range, dest As Range, tablo, resu(), d As Object, n&, i&, nn&, j%
ncol = 4 'nombre de colonnes il faut prendre jusqu'à la colonne D

Set source = Sheets("Template").[A1].CurrentRegion.Resize(, ncol)
Set dest = Sheets("Destination").Range("A" & Rows.Count).End(xlUp)(2) '1ère cellule vide

tablo = source 'matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To ncol)
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode...
bonjour
utilise la fonction split

en supposant que la varialbe "AdresseMail" contiennent l'adresse
Domaine=split(AdresseMail,"@")(1)

Sub Concat3()
Dim conc(), n&, i&
Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1") = "Concatenation(Division&EmailPro)"
With ActiveSheet
n = .Cells(.Rows.Count, 67).End(xlUp).Row
i = .Cells(.Rows.Count, 79).End(xlUp).Row
n = IIf(i > n, i, n)
ReDim conc(1 To n - 1, 1 To 1)
For i = 2 To n
If .Cells(i, 67) <> "" Or .Cells(i, 79) <> "" Then
conc(i - 1, 1) = trim(.Cells(i, 67) & " " & (Split(.Cells(i, 79).Value, "@")(1)))
End If
Next i
.Cells(2, 1).Resize(n - 1).Value = conc
End With
End Sub
 
Sub Concat3()
Dim conc(), n&, i&
Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1") = "Concatenation(Division&EmailPro)"
With ActiveSheet
n = .Cells(.Rows.Count, 67).End(xlUp).Row
i = .Cells(.Rows.Count, 79).End(xlUp).Row
n = IIf(i > n, i, n)
ReDim conc(1 To n - 1, 1 To 1)
For i = 2 To n
If .Cells(i, 67) <> "" Or .Cells(i, 79) <> "" Then
conc(i - 1, 1) = trim(.Cells(i, 67) & " " & (Split(.Cells(i, 79).Value, "@")(1)))
End If
Next i
.Cells(2, 1).Resize(n - 1).Value = conc
End With
End Sub

comme je n'ai pas vraiment suivi la discussion, il faudrait que tu repostes la dernière version de ton fichier avec cette macro, et dire sur quelle feuille tu ajoutes la colonne A ..
 
comme je n'ai pas vraiment suivi la discussion, il faudrait que tu repostes la dernière version de ton fichier avec cette macro, et dire sur quelle feuille tu ajoutes la colonne A ..
Bonjour je reviens vers toi ,car dans le premier fichier, j'aimerais concaténer la division qui se trouve en colonne A et le domaine de l'adresse mail qu'il faudrait extraire (ex:"domaine.com")qui se trouve en colonne d.
Ainsi ne copier que ligne qui ont pour [division ="Holding" et le domaine ="domaine.net" ] et ceux qui ont pour [division ="transport" et le domaine ="domaine.net" ] dans l'onglet "destination.

Tout ceci en le rajoutant au code que tu m'avais remis.
J'ai essayer de m'y aventurer toutes la journée en le rajoutant au code que tu m'avais fournis mais je pense qu'il me manques certaines connaissance pour utiliser split().

Voici le fichier
 

Pièces jointes

Hello

j'ai repris le code de @job75 que j'ai juste adapté pour ajouter le nouveau critère "HoldingDomaine.net"

je te laisse vérifier
VB:
Sub Transfert2()
Dim ncol%, source As Range, dest As Range, tablo, resu(), d As Object, n&, i&, nn&, j%
ncol = 4 'nombre de colonnes il faut prendre jusqu'à la colonne D

Set source = Sheets("Template").[A1].CurrentRegion.Resize(, ncol)
Set dest = Sheets("Destination").Range("A" & Rows.Count).End(xlUp)(2) '1ère cellule vide

tablo = source 'matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To ncol)
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
d("Transporta") = "": d("Holdingb") = "": d("AutresDacom") = "": d("HoldingDomaine.net") = "" 'créer une clé pour chaque critère
n = 1
For i = 2 To UBound(tablo)
    If d.exists(tablo(i, 1) & tablo(i, 2)) Or d.exists(tablo(i, 1) & Split(tablo(i, 4), "@")(1)) Then
        nn = nn + 1
        For j = 1 To ncol
            resu(nn, j) = tablo(i, j)
        Next j
    Else
        n = n + 1
        For j = 1 To ncol
            tablo(n, j) = tablo(i, j)
        Next j
    End If
Next i
'---restitution des 2 tableaux---
If source.Parent.FilterMode Then source.Parent.ShowAllData 'si la feuille est filtrée
If dest.Parent.FilterMode Then dest.Parent.ShowAllData 'si la feuille est filtrée
source.Resize(n) = tablo
source.Offset(n).Resize(Rows.Count - n - source.Row + 1).ClearContents 'RAZ en dessous
If nn Then dest.Resize(nn, ncol) = resu
dest.Offset(nn).Resize(Rows.Count - nn - dest.Row + 1, ncol).ClearContents 'RAZ en dessous
MsgBox nn & " ligne(s) sur " & n - 1 + nn & " transférée(s)..."
End Sub
 
il faut utiliser le bon fichier.... celui qui possède ta colonne D avec les adresses mails...
Oui oui je utilise déjà sauf que parfois dans mon fichier, l'adresse mail n'est pas forcément renseigné.. Et j'ai remarqué des qu'il n'est pas renseigner la macro met erreur d'exécution.
EXEMPLE:si t'enlève un mail dans la colonne D tu verra #Erreur d'execution"9"..et si tu rempli l'adresse elle tourne normalement
 
avec cette modif de code

en cas d'erreur.. on continue..
ca ne regle pas le problème d'adresse manquante.. et ca ignore l'erreur, quelque soit son origine...
c'est un peu comme quand t'es en voiture.. si plus de frein. et bah.. tu continues quand meme.. advienne que pourra..

VB:
Sub Transfert2()
Dim ncol%, source As Range, dest As Range, tablo, resu(), d As Object, n&, i&, nn&, j%
ncol = 4 'nombre de colonnes il faut prendre jusqu'à la colonne D

Set source = Sheets("Template").[A1].CurrentRegion.Resize(, ncol)
Set dest = Sheets("Destination").Range("A" & Rows.Count).End(xlUp)(2) '1ère cellule vide

tablo = source 'matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To ncol)
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
d("Transporta") = "": d("Holdingb") = "": d("AutresDacom") = "": d("HoldingDomaine.net") = "" 'créer une clé pour chaque critère
n = 1
On Error Resume Next
For i = 2 To UBound(tablo)
    If d.exists(tablo(i, 1) & tablo(i, 2)) Or d.exists(tablo(i, 1) & Split(tablo(i, 4), "@")(1)) Then
        nn = nn + 1
        For j = 1 To ncol
            resu(nn, j) = tablo(i, j)
        Next j
    Else
        n = n + 1
        For j = 1 To ncol
            tablo(n, j) = tablo(i, j)
        Next j
    End If
Next i
'---restitution des 2 tableaux---
If source.Parent.FilterMode Then source.Parent.ShowAllData 'si la feuille est filtrée
If dest.Parent.FilterMode Then dest.Parent.ShowAllData 'si la feuille est filtrée
source.Resize(n) = tablo
source.Offset(n).Resize(Rows.Count - n - source.Row + 1).ClearContents 'RAZ en dessous
If nn Then dest.Resize(nn, ncol) = resu
dest.Offset(nn).Resize(Rows.Count - nn - dest.Row + 1, ncol).ClearContents 'RAZ en dessous
MsgBox nn & " ligne(s) sur " & n - 1 + nn & " transférée(s)..."
End Sub
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
1
Affichages
395
Retour