XL 2019 copier une colonne si

[Jerry590]

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.

 

[Jerry590]

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

 

[vgendron]

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 ..

 

[Jerry590]

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

 

[vgendron]

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

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

 

[Jerry590]

@vgendron le code il fonctionne pas vraiment ,j'ai l'impression que la cellule est vide la macro s’arrête.

 

[vgendron]

il faut utiliser le bon fichier.... celui qui possède ta colonne D avec les adresses mails...

 

[vgendron]

Ce qui souligne un problème.. si une des lignes ne possède pas d'adresse mail.. ca plante

 

[Jerry590]

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

 

[vgendron]

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..

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