Bonsoir,
au vu de ton fichier, j'ai pensé à un truc.....
Tu as des adresses mails.....
Avec ce que j'ai concocté, tu as autant de fichiers que d'initiales....
Le code te permet d'enregistrer dans chaque fichier ( "Noms A", "Noms B"..........), tous les contacts commençant par ces lettres....
Pour bien utiliser mon fichier exemple, enregistre-le dans un répertoire spécifique, ce sera plus facile.....
Le code :
Sub balayage()
Dim Cel As Range
Dim Initiales As Object
Dim It
Dim LePath As String, LeNom As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ActiveSheet
If InStr(.Range("A1"), "@") > 0 Then
.Rows("1:1").Insert Shift:=xlDown
End If
If .Range("A1").Value <> "Adresses Mail" Then
.Range("A1").Value = "Adresses Mail"
End If
Set Initiales = CreateObject("Scripting.Dictionary")
.Range("A1:A" & .[A65000].End(xlUp).Row).Name = "base"
.Range("A2:A" & .[A65000].End(xlUp).Row).Name = "base2"
For Each Cel In .Range("base2")
If Not Initiales.Exists(UCase(Left(Cel, 1))) Then _
Initiales.Add UCase(Left(Cel, 1)), UCase(Left(Cel, 1))
Next Cel
LePath = ActiveWorkbook.Path & "\"
For Each It In Initiales.Items
LeNom = "Noms " & It & ".xls"
Sheets.Add
Range("A1").Value = .Range("A1").Value
Range("B2").FormulaR1C1 = "=UPPER(LEFT(" & .Name & "!RC1,1))=""" & It & """"
.Range("base").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"B1:B2"), CopyToRange:=Range("A1"), Unique:=False
Cells.Columns.AutoFit
[B2].ClearContents
With ActiveSheet
.Name = LeNom
.Move
End With
With ActiveWorkbook
.SaveAs Filename:=LePath & LeNom
.Close
End With
Next It
End With
End Sub
Le fichier exemple :
https://www.excel-pratique.com/~files/doc/adresses.zip
Edit, et j'oubliais......
Avec ton fichier exemple, sur mon PC, le code se déroule en un peu moins de 7 secondes....
Sur ton fichier réel, s'il comporte plusieurs milliers de lignes, ce pourrait être un tout petit peu plus long......
Bon courage