'### Adapter les constantes selon son usage ###
Const FEUILLE As String = "test"
Const DOMAINE As String = "@domaine.fr"
Const IMPORT As String = "import" 'dernière importation de la BDD
'##############################################
Sub ImportVersusTest()
Dim S As Worksheet
Dim S2 As Worksheet
Dim R As Range
Dim var
Dim var2
Dim lastLig&
Dim i&
Dim j&
Dim k&
On Error GoTo Erreur
Application.ScreenUpdating = False
Sheets(FEUILLE).Copy after:=Sheets(Sheets.Count)
Set S = ActiveSheet
lastLig& = S.[a65536].End(xlUp).Row
Set R = S.Range(S.Cells(1, 1), S.Cells(lastLig&, 6))
R.Sort Key1:=[a1], Order1:=xlAscending, Header:=xlYes
var = R
R.ClearContents
Sheets(IMPORT).Cells.Copy
S.[a1].Select
ActiveSheet.Paste
lastLig& = S.[a65536].End(xlUp).Row
Set R = S.Range(S.Cells(1, 1), S.Cells(lastLig&, 6))
R.Sort Key1:=[a1], Order1:=xlAscending, Header:=xlYes
var2 = R
R.ClearContents
For i& = 2 To UBound(var2, 1)
For k& = 2 To UBound(var, 1)
If Trim(var2(i&, 1)) = Trim(var(k&, 1)) Then
If Trim(var(k&, 5)) <> "" And Trim(var(k&, 6)) <> "" Then
For j& = 1 To UBound(var2, 2)
var2(i&, j&) = ""
Next j&
End If
Exit For
End If
Next k&
Next i&
R = var2
R.Sort Key1:=[a1], Order1:=xlAscending, Header:=xlYes
lastLig& = S.[a65536].End(xlUp).Row
Set R = S.Range(S.Cells(2, 1), S.Cells(lastLig&, 6))
R.Copy
Sheets(FEUILLE).Activate
Set R = Range("a" & ActiveSheet.[a65536].End(xlUp).Row + 1 & "")
R.Select
ActiveSheet.Paste
Application.CutCopyMode = False
R.Select
Application.DisplayAlerts = False
S.Delete
Call LoginsEtMails
Erreur:
Application.DisplayAlerts = False
Application.ScreenUpdating = True
If Err <> 0 Then MsgBox Err.Number & vbCrLf & Err.Description
End Sub
Sub LoginsEtMails()
Dim S As Worksheet
Dim R As Range
Dim var
Dim var2
Dim A$
Dim B$
Dim prenom$
Dim nom$
Dim i&
Dim j&
Dim cpt&
Dim lastLig&
Dim bool As Boolean
Set S = Sheets(FEUILLE)
lastLig& = S.[b65536].End(xlUp).Row
var = S.Range(S.Cells(1, 1), S.Cells(lastLig&, 6))
Set R = S.Range(S.Cells(1, 5), S.Cells(lastLig&, 6))
var2 = R
For i& = 1 To lastLig&
nom$ = Cleaning(var(i&, 3))
prenom$ = Cleaning(var(i&, 2))
'--- Login ---
A$ = Trim(var(i&, 5))
If A$ = "" Then
A$ = Left(nom$, 3) & Left(prenom$, 2)
cpt& = 0
Do
B$ = A$
If cpt& > 0 Then B$ = B$ & cpt&
bool = False
For j& = LBound(var2, 1) To UBound(var2, 1)
If B$ = var2(j&, 1) Then
bool = True
cpt& = cpt& + 1
Exit For
End If
Next j&
Loop Until bool = False
var2(i&, 1) = B$
End If
'--- Mail ---
A$ = Trim(var(i&, 6))
If A$ = "" Then
A$ = prenom$ & "." & nom$
cpt& = 0
Do
B$ = A$
If cpt& > 0 Then B$ = B$ & cpt&
bool = False
For j& = LBound(var2, 1) To UBound(var2, 1)
If B$ & DOMAINE = var2(j&, 2) Then
bool = True
cpt& = cpt& + 1
Exit For
End If
Next j&
Loop Until bool = False
var2(i&, 2) = B$ & DOMAINE
End If
Next i&
R = var2
End Sub
Private Function Cleaning(ByVal Chaine As String) As String
Dim i&
Dim NoChar
Dim Accent
NoChar = Array(" ", "", "'", "", "-", "")
Accent = Array("à", "a", "â", "a", "è", "e", "é", "e", "ê", "e", "ë", "e", _
"î", "i", "ï", "i", "ô", "o", "ö", "o", "ù", "u", "û", "u", "ü", "u")
For i& = LBound(NoChar) To UBound(NoChar) Step 2
Chaine = Replace(Chaine, NoChar(i&), NoChar(i& + 1))
Next i&
For i& = LBound(Accent) To UBound(Accent) Step 2
Chaine = Replace(Chaine, Accent(i&), Accent(i& + 1))
Next i&
Cleaning = LCase(Chaine)
End Function