XL 2010 copier le contenu des cellules contenant @ sur une nouvelle feuille

[superbog]

Bonjour,

Pb récurrent. Je télécharge des listes de noms en CSV et quand je les transforme en xls j'ai un gros bordel. En réalité je n'ai besoin que des adresses email.
Il faut donc que je trouve toutes les cellules qui contiennent @ et que je les copie dans une nouvelle feuille.
help

 

[Lone-wolf]

Bonsoir superbog

Une fois mis en xls, un exemple

With Feuil1
set plage = .Range("a2:a" & .Range("a" & rows.count).end(xlUp).row)
For each cel in plage
If cel Like "*@*" Then
cel.Copy .Range("f65536").end(xlup)(2)
End If
Next cel
End With

 

[superbog]

merci j'ai fait une macro mais c'est super lent, si vous aviez une idée d'accélération

Dim sh1 As Worksheet, sh2 As Worksheet, lig&, i&
Dim plage As Range
Dim cel As Variant


Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
        Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
        ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
        (20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), _
        Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array( _
        33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1), Array(38, 1), Array(39, 1), _
        Array(40, 1), Array(41, 1), Array(42, 1), Array(43, 1), Array(44, 1), Array(45, 1), Array( _
        46, 1), Array(47, 1), Array(48, 1), Array(49, 1), Array(50, 1), Array(51, 1), Array(52, 1), _
        Array(53, 1), Array(54, 1), Array(55, 1), Array(56, 1), Array(57, 1), Array(58, 1), Array( _
        59, 1), Array(60, 1), Array(61, 1), Array(62, 1), Array(63, 1), Array(64, 1), Array(65, 1), _
        Array(66, 1), Array(67, 1), Array(68, 1), Array(69, 1), Array(70, 1), Array(71, 1), Array( _
        72, 1), Array(73, 1), Array(74, 1), Array(75, 1), Array(76, 1), Array(77, 1), Array(78, 1), _
        Array(79, 1), Array(80, 1), Array(81, 1), Array(82, 1), Array(83, 1), Array(84, 1), Array( _
        85, 1), Array(86, 1), Array(87, 1), Array(88, 1)), TrailingMinusNumbers:=True
    Cells.Select

ActiveSheet.Name = "google"

Sheets.Add.Name = "email"

With Sheets("google")
Set plage = .Range("a2:CZ900" & .Range("a" & Rows.Count).End(xlUp).Row)
For Each cel In plage
If cel Like "*@*" Then
cel.Copy Sheets("email").Range("A2000").End(xlUp)(2)
End If
Next cel
End With
  
Sheets("email").Range("$A$2:$A$2000").RemoveDuplicates Columns:=Array(1), Header:=xlNo
  
MsgBox "fini"

End Sub

 

[Lone-wolf]

Re,

Pour une macro plus rapide il faut peut-être passer par un tableau ou utiliser scripting dictionary, mais là je ne sais pas faire.