superbog
XLDnaute Occasionnel
Bonjour,
j'ai une macro (cf ci dessous) que je voudrais rendre automatiquement disponible pour tous les classeurs excels s'ouvrant sur une certaine machine.
En fait voici la situation:
la secrétaire de l'association doit prendre des fichiers csv (en fait des imports des contacts gmail) et les transformer en une liste d'email (cf https://www.excel-downloads.com/thr...-contenant-sur-une-nouvelle-feuille.20014617/)
J'ai donc (avec l'aide du forum 🙂 créé une macro qui fonctionne bien (quoiqu'un peu lente, si vous avez une idée d'accélération...). Je voudrais que cette macro soit disponible chaque fois qu'elle ouvrira excel ainsi elle pourra l'appliquer à ses nouveaux csv.
merci d'avance
j'ai une macro (cf ci dessous) que je voudrais rendre automatiquement disponible pour tous les classeurs excels s'ouvrant sur une certaine machine.
En fait voici la situation:
la secrétaire de l'association doit prendre des fichiers csv (en fait des imports des contacts gmail) et les transformer en une liste d'email (cf https://www.excel-downloads.com/thr...-contenant-sur-une-nouvelle-feuille.20014617/)
J'ai donc (avec l'aide du forum 🙂 créé une macro qui fonctionne bien (quoiqu'un peu lente, si vous avez une idée d'accélération...). Je voudrais que cette macro soit disponible chaque fois qu'elle ouvrira excel ainsi elle pourra l'appliquer à ses nouveaux csv.
merci d'avance
VB:
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