1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
| Option Explicit
Sub Main()
Const Rep = "C:\Documents and Settings\*****\Bureau\*****\" ' le répertoire contenant les fichiers..
Dim TheFile As String 'Variable pour le nom du fichier
Dim NewFile As String
Dim DateDeb As Date, DateFin As Date, TempsTot As Date
'Chrono
DateDeb = Time
Application.ScreenUpdating = False
Application.DisplayAlerts = False
TheFile = Dir(Rep & "*.xlsx") 'Listing des fichier Excel...
While TheFile <> "" 'Tant que non vide
Workbooks.Open (Rep & TheFile) 'Ouverture du fichier
Call Epuration_fichiers_Main
'Epuration du nom du fichier (en enlève l'extention *.xlsx
NewFile = Left(TheFile, InStrRev(TheFile, ".") - 1)
ChDir "C:\Documents and Settings\*****\Bureau\*****"
ActiveWorkbook.SaveAs Filename:="C:\Documents and Settings\*****\Bureau\*****\" & NewFile & ".csv", FileFormat:=xlCSV, CreateBackup:=False
ActiveWindow.Close
TheFile = Dir 'Fichier suivant
Wend
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Fin du chrono
DateFin = Time
TempsTot = DateFin - DateDeb
MsgBox "Traitement terminé" & vbCrLf & TempsTot
End Sub
Sub Epuration_fichiers_Main()
Rows("1:1").Delete
Columns("I:J").Delete
'Suppression des lignes où il manque le CP ou la ville ou les deux
Call Suppression_Lignes_inexploitables("C:D")
'Suppression des doublons
Call Suppression_doublons
'Format "téléphone pour les case E,F,G
Application.ErrorCheckingOptions.BackgroundChecking = False 'Suppression des balises actives
Column("E:G").NumberFormat = "0#"" ""##"" ""##"" ""##"" ""##"
End Sub
Sub Suppression_doublons()
'Les déclarations des variables
Dim sNumTel As String, sNom As String, sAdd As String, iCP As String, sChaine As String
Dim iNb_Lignes As Long, iPos1 As Byte, iNombreCell_1 As Long, iNombreCell_2 As Long
Dim rCible As Range, iLigne As Long, rRgeA As Range, rRgeB As Range, i As Long
iNb_Lignes = ActiveSheet.UsedRange.Rows.Count
'Boucle sur toutes les lignes du fichier
For i = iNb_Lignes To 1 Step -1
'Transformation des minuscules en majuscules dans les colonnes A,B,D,I
Range("A", i).Value = Replace(Range("A", i).Value, Range("A", i).Value, UCase(Range("A", i).Value))
Range("B", i).Value = Replace(Range("B", i).Value, Range("B", i).Value, UCase(Range("B", i).Value))
Range("D", i).Value = Replace(Range("D", i).Value, Range("D", i).Value, UCase(Range("D", i).Value))
Range("I", i).Value = Replace(Range("I", i).Value, Range("I", i).Value, UCase(Range("I", i).Value))
'On en profite pour faire le transfert des numéros de mobile de la colonne "fixe" vers la colonne "mobile"
'#####################################
If Left(Range("E" & i).Value, 2) = "06" Then
If Range("G" & i).Value = "" Then
Range("G" & i).Value = Range("E" & i).Value
Else
Range("E" & i).ClearContents
End If
End If
'On en profite pour faire la Suppression des parasites symbolisés par "-" dans la colonne B
'Dans la colonne B, on ne veut garder que les données se trouvant APRES le dernier tiret
sChaine = Range("B" & i).Value
iPos1 = InStrRev(sChaine, "-")
If iPos1 > 0 Then
Range("B" & i).Value = Mid(sChaine, iPos1 + 1)
End If
'Suppression des doublons
sNumTel = Range("E" & i).Value
sNom = Range("A" & i).Value
iCP = Range("C" & i).Value
sAdd = Range("B" & i).Value
If sNumTel <> "" Then
Set rCible = Range("E1:E" & i).Find(what:=sNumTel, lookat:=xlWhole)
If Not rCible Is Nothing Then
iLigne = rCible.Row
'On supprime un doublons uniquement si les colonnes A,B et C sont identiques
If Range("A" & iLigne).Value = sNom And Range("B" & iLigne).Value = sAdd And Range("C" & iLigne).Value = iCP Then
Set rRgeA = Range("A" & i & ":K" & i)
Set rRgeB = Range("A" & iLigne & ":K" & iLigne)
iNombreCell_1 = Application.WorksheetFunction.CountBlank(rRgeA)
iNombreCell_2 = Application.WorksheetFunction.CountBlank(rRgeB)
Set rRgeA = Nothing
Set rRgeB = Nothing
'La ligne contenant le plus de colonne vide est supprimée
If iNombreCell_1 > iNombreCell_2 Or i <> iLigne Then
Range("A" & iLigne).EntireRow.Delete
End If
End If
End If
Set rCible = Nothing
End If
Next i
End Sub
Public Sub Suppression_Lignes_inexploitables(rRge As String)
Dim rCible As Range
Dim iNb_Lignes As Long
iNb_Lignes = ActiveSheet.UsedRange.Rows.Count
If iNb_Lignes > 1 Then
Do
Set rCible = Range(rRge).Find("", lookat:=xlWhole, SearchOrder:=xlByRows)
If Not rCible Is Nothing Then
If rCible.Row > iNb_Lignes Then Exit Do
iNb_Lignes = iNb_Lignes - 1
rCible.EntireRow.Delete
End If
Loop
End If
End Sub |
Optimisation de code
Répondre avec citation
Envoyé par mercatog
bonne chance)
Partager