Option Explicit
Option Base 1
Sub Lance_Macros()
If MsgBox("Voulez-vous importer une mise à jour de vos adresses ?", vbYesNo + vbQuestion, _
"Demande de confirmation") = vbYes Then
Call Copie_Donnees
Application.ScreenUpdating = False
Call Supprimer_Colonnes_G
Call Renommage_Colonnes_G
Call Formatage
Call Tri_Nom_Prenom
Call Rassemble_Mails
Call Rassemble_Telephones
Application.ScreenUpdating = True
Call Mise_en_Forme
Else
MsgBox "Importation annulée", vbOKOnly + vbInformation, "Aucune modification effectuée"
Exit Sub
End If
End Sub
Sub Filtres_On_Off()
' Filtre sur les noms situés sur l'onglet "Liste" (ou retire le filtre s'il est actif)
Dim Tablo() As Variant
Dim NomTableau As String
Dim NbContact As Integer
Dim i As Integer
Dim DerLigne As Integer
Application.ScreenUpdating = False
If Worksheets("Contacts").FilterMode Then
Worksheets("Contacts").ShowAllData
Worksheets("Contacts").Shapes("Button 5").Visible = False
Worksheets("Contacts").Shapes("Button 1").Visible = True
Else
DerLigne = Worksheets("Liste").Range("A65000").End(xlUp).Row
' Redimension automatique du tableau en fonction du nombre de lignes occupées
ReDim Tablo(2 To DerLigne)
For i = LBound(Tablo) To UBound(Tablo)
Tablo(i) = Sheets("Liste").Cells(i, "A").Value
Next i
NomTableau = Worksheets("Contacts").ListObjects(1).Name
Worksheets("Contacts").ListObjects(NomTableau).Range.AutoFilter Field:=1, Criteria1:= _
Array(Tablo), Operator:=xlFilterValues
Worksheets("Contacts").Shapes("Button 1").Visible = False
Worksheets("Contacts").Shapes("Button 5").Visible = True
End If
Call Masque_lignes_condition_cellule
Application.Goto Range("A2"), Scroll:=True
' Affichage du nombre d'enregistrements filtrés ou total
NbContact = Application.Subtotal(3, Columns("A")) - 1
Application.ScreenUpdating = True
MsgBox NbContact & " contacts affichés", vbOKOnly + vbInformation, "Information"
End Sub
Sub Masque_lignes_condition_cellule()
' Masque des lignes dans le cas ou l'on ne veut pas afficher certaines personnes qui auraient le même nom de famille (ex. Xxxxx Nicole)
' Recherche sur Nom et Prénom des colonnes F et G de la feuille Liste
Dim lg As Long, r As Long
Dim Tablo() As Variant
Dim i, j As Integer
Dim DerLigM As Integer
With ActiveSheet.UsedRange
lg = .Row + .Rows.Count - 1
End With
DerLigM = Sheets("Liste").Range("F65000").End(xlUp).Row
Dim Tab_Masquer()
ReDim Tab_Masquer(DerLigM - 1, 2)
For i = 1 To DerLigM - 1
Tab_Masquer(i, 1) = Sheets("Liste").Range("F" & i + 1)
Tab_Masquer(i, 2) = Sheets("Liste").Range("G" & i + 1)
For r = lg To 1 Step -1
If Cells(r, "A") Like Tab_Masquer(i, 1) And Cells(r, "B") Like Tab_Masquer(i, 2) Then
Rows(r).EntireRow.Hidden = True
End If
Next r
Next
End Sub
Sub Supprimer_Liaison()
Dim NomTableau As String
NomTableau = Worksheets("Contacts").ListObjects(1).Name
'Supprimer le lien du tableau
ActiveSheet.ListObjects(NomTableau).Unlink
End Sub
Sub Supprimer_Colonnes_G()
' Suppression des colonnes inutiles
Dim FE, FC, FL As Sheets
Set FE = Worksheets("Export")
Set FC = Worksheets("Contacts")
' Déplacement de la colonne des noms située col. D en col. A
FC.Select
FC.Columns("D:D").Cut
Columns("A:A").Insert shift:=xlToRight
'Columns("A:A").Select
'Selection.Insert shift:=xlToRight
' Suppression des colonnes inutiles
Columns("B:B").Delete shift:=xlToLeft
Columns("C:M").Delete shift:=xlToLeft
Columns("D:M").Delete shift:=xlToLeft
Columns("E:H").Delete shift:=xlToLeft
Columns("F:F").Delete shift:=xlToLeft
Columns("G:G").Delete shift:=xlToLeft
Columns("H:L").Delete shift:=xlToLeft
Columns("I:I").Delete shift:=xlToLeft
Columns("J:J").Delete shift:=xlToLeft
Columns("K:P").Delete shift:=xlToLeft
Columns("M:N").Delete shift:=xlToLeft
Columns("N:AH").Delete shift:=xlToLeft
End Sub
Sub Renommage_Colonnes_G()
' Renommage_Colonnes Macro
'
Dim NomTableau As String
NomTableau = Worksheets("Contacts").ListObjects(1).Name
Sheets("Contacts").Select
Range("A1") = "Nom"
Range("B1") = "Prénom"
Range("C1") = "D.Nais."
Range("E1") = "E-Mail"
Range("F1") = "E-Mail2"
Range("G1") = "E-Mail3"
Range("H1") = "Mobile"
Range("I1") = "Tél. Domicile"
Range("J1") = "Tél. Travail"
Range("K1") = "Adresse"
Range("L1") = "Ville"
Range("M1") = "C.Postal"
'Range("C2").Select
End Sub
Sub Selection_Donnees()
Dim CelDeb As String
Dim CelFin As String
CelDeb = Range("A1").Address
CelFin = Range("A1").SpecialCells(xlCellTypeLastCell).Address
' Sélection et copie de toutes les cellules occupées de la feuille
Range(CelDeb & ":" & CelFin).Select
End Sub
Sub Copie_Donnees()
Dim NomFeuil As String
Dim nbOnglets As Integer
Dim k As Integer, i As Integer
Dim CelDeb As String
Dim CelFin As String
' Nommage de la feuille Export
k = Sheets.Count
If k > 4 Then
For i = 1 To k
'Sheets(i).Activate
NomFeuil = Sheets(i).Name
'If ActiveSheet.Name <> "Export" Or ActiveSheet.Name <> "Explications" Or ActiveSheet.Name <> "Contacts" Then
If NomFeuil <> "Liste" And NomFeuil <> "Explications Export Outlook" And NomFeuil <> "Explications Export Google" And NomFeuil <> "Contacts" Then
Sheets(i).Select
ActiveSheet.Name = "Export"
'Exit Sub
End If
Next i
' Sheets("Export").Select
Else
MsgBox "Les données n'ont pas encore été importées." & vbCrLf & _
"Avant de poursuivre vous devez avoir effectué l'import." & vbCrLf & _
"(une nouvelle feuille sera visible).", vbOKOnly + vbInformation, "Informations"
End
End If
' Supprime les données de la feuille de travail "Listing_Adresses"
Worksheets("Export").Select
CelDeb = Worksheets("Contacts").Range("A1").Address
CelFin = Worksheets("Contacts").Range("A1").SpecialCells(xlCellTypeLastCell).Address
Worksheets("Contacts").Range(CelDeb & ":" & CelFin).ClearContents
CelDeb = Worksheets("Export").Range("A1").Address
CelFin = Worksheets("Export").Range("A1").SpecialCells(xlCellTypeLastCell).Address
'Copie de toutes les cellules occupées de la feuille "Export" sur la feuille "Contacts"
Worksheets("Export").Range(CelDeb & ":" & CelFin).Copy (Worksheets("Contacts").Range("A1"))
End Sub
Sub Formatage()
' Mise en forme du tableau
Dim NomTableau As String
Dim DerLigne As Integer
' Déplacement de la colonne D en fin de tableau
DerLigne = Range("D65000").End(xlUp).Row
Range("D1:D" & DerLigne).Select
Application.CutCopyMode = False
Selection.Copy
Range("N1").Select
ActiveSheet.Paste
Columns("D:D").Delete shift:=xlToLeft
Range("M1") = "Notes"
' Récupération du nom du tableau dans la variable NomTableau (change à chaque fois)
NomTableau = Worksheets("Contacts").ListObjects(1).Name
' Tri sur Nom et Prénom
ActiveWorkbook.Worksheets("Contacts").ListObjects(NomTableau).Sort. _
SortFields.Clear
ActiveWorkbook.Worksheets("Contacts").ListObjects(NomTableau).Sort. _
SortFields.Add2 Key:=Range(NomTableau & "[Nom]"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Contacts").ListObjects(NomTableau).Sort. _
SortFields.Add2 Key:=Range(NomTableau & "[Prénom]"), SortOn:= _
xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Contacts").ListObjects(NomTableau).Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Suppression de la liaison avec la bd
NomTableau = Worksheets("Contacts").ListObjects(1).Name
ActiveSheet.ListObjects(NomTableau).Unlink
Call Supprimer_Retour_Ligne
End Sub
Sub Tri_Nom_Prenom()
' Tri_Nom_Prenom Macro
Dim NomTableau As String
Dim NbContact As Integer
' Récupération du nom du tableau dans la variable NomTableau (change à chaque fois)
NomTableau = Worksheets("Contacts").ListObjects(1).Name
ActiveWorkbook.Worksheets("Contacts").ListObjects(NomTableau).Sort. _
SortFields.Clear
ActiveWorkbook.Worksheets("Contacts").ListObjects(NomTableau).Sort. _
SortFields.Add2 Key:=Range(NomTableau & "[Nom]"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Contacts").ListObjects(NomTableau).Sort. _
SortFields.Add2 Key:=Range(NomTableau & "[Prénom]"), SortOn:=xlSortOnValues _
, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Contacts").ListObjects(NomTableau).Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Sub Supprimer_Retour_Ligne()
'Supprime les retours à la ligne colonne M
Dim DerLigne As Integer
Dim i As Integer
Dim Cpt As Integer
DerLigne = Range("A65000").End(xlUp).Row
Cpt = 0
On Error Resume Next
'For Cpt = 1 To 5
For i = 1 To DerLigne
For Cpt = 1 To 3
Range("M" & i).Select
Selection.Replace What:=Chr(10) & Chr(10), Replacement:=Chr(10)
If Right(Selection, 1) = Chr(10) Then Selection = Left(Selection, Len(Selection) - 1)
Next Cpt
Next i
' Resserage des lignes en fonction du contenu
Rows("2:" & DerLigne).EntireRow.AutoFit
End Sub
Sub Mise_en_Forme()
'Met en forme le fichier
Dim NbContact, DerLigne As Integer
Application.ScreenUpdating = False
DerLigne = Range("A65000").End(xlUp).Row
' Dimensionnement de la largeur des colonnes
Columns("A:B").ColumnWidth = 20
Columns("C:C").Select
With Selection
.ColumnWidth = 12
.HorizontalAlignment = xlCenter
End With
Columns("D:D").ColumnWidth = 45
Columns("D:D").Select
With Selection
.HorizontalAlignment = xlLeft
End With
Columns("E:E").Select
With Selection
.ColumnWidth = 18
.HorizontalAlignment = xlCenter
End With
Columns("F:F").ColumnWidth = 35
Columns("G:G").ColumnWidth = 18
Columns("H:H").Select
With Selection
.ColumnWidth = 12
.HorizontalAlignment = xlCenter
End With
Columns("I:I").ColumnWidth = 75
Columns("J:J").ColumnWidth = 2
' Formatage colonne I (retour à la ligne)
Columns("F:F").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
' Formatage colonne I (retour à la ligne)
Columns("I:I").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
' Formatage centrage des données en vertical
Rows("2:" & DerLigne).Select
With Selection
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Affichage en pleine largeur d'écran
Application.CommandBars("Queries and Connections").Visible = False
Range("A1:J1").Select
ActiveWindow.Zoom = True
Range("A2").Select
Application.ScreenUpdating = True
' Affichage du nombre d'enregistrements filtrés ou total
NbContact = Application.Subtotal(3, Columns("A")) - 1
Application.Goto Range("A2"), Scroll:=True
MsgBox NbContact & " contacts affichés", vbOKOnly + vbInformation, "Information"
End Sub
Sub Rassemble_Mails()
Dim DerLigne As Integer
Dim i As Integer
Dim NomTableau As String
Dim Cpt As Integer
Dim MailGlobal, Mail1, Mail2, Mail3 As String
Const ColRgtMails = "D" 'Regroupement E-Mails
Const ColMail1 = "E" 'Mail1
Const ColMail2 = "F" 'E-Mail2
Const ColMail3 = "G" 'E-Mail3
DerLigne = Range("A65000").End(xlUp).Row
Columns(ColRgtMails & ":" & ColRgtMails).Select
Selection.Insert shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range(ColRgtMails & 1) = "E-Mails"
For i = 2 To DerLigne
Mail1 = Range(ColMail1 & i).Value
Mail2 = Range(ColMail2 & i).Value
Mail3 = Range(ColMail3 & i).Value
If Mail1 <> "" Then
MailGlobal = Mail1
End If
If Mail2 <> "" Then
MailGlobal = Mail2
End If
If Mail3 <> "" Then
MailGlobal = Mail3
End If
If Mail1 <> "" And Mail2 <> "" Then
MailGlobal = Mail1 & vbCrLf & Mail2
End If
If Mail1 <> "" And Mail3 <> "" Then
MailGlobal = Mail1 & vbCrLf & Mail3
End If
If Mail2 <> "" And Mail3 <> "" Then
MailGlobal = Mail2 & vbCrLf & Mail3
End If
If Mail1 <> "" And Mail2 <> "" And Mail3 <> "" Then
MailGlobal = Mail1 & vbCrLf & Mail2 & vbCrLf & Mail3
End If
Range(ColRgtMails & i) = MailGlobal
Mail1 = Empty
Mail2 = Empty
Mail3 = Empty
MailGlobal = Empty
Next i
'Suppression des ":" parasites
Columns(ColRgtMails & ":" & ColRgtMails).Select
Selection.Replace What:=":", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Suppression des anciennes colonnes mail
Columns(ColMail1 & ":" & ColMail3).Delete shift:=xlToLeft
End Sub
Sub Rassemble_Telephones()
Dim DerLigne As Integer
Dim i As Integer
Dim NomTableau As String
Dim Cpt As Integer
Dim TelGlobal, Tel1, Tel2, Tel3, ValTel3 As String
Const ColRgtTel = "E"
Const ColMobile = "F"
Const ColDomicile = "G"
Const ColTravail = "H"
Const ColJ = "J"
Const ColK = "K"
Const ColL = "L"
'Appel de la procédure qui formatte les n° de tél.
Call AjouteEspace
DerLigne = Range("A65000").End(xlUp).Row
NomTableau = Worksheets("Contacts").ListObjects(1).Name
Columns(ColRgtTel & ":" & ColRgtTel).Select
Selection.Insert shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range(ColRgtTel & 1) = "Téléphones"
For i = 2 To DerLigne
Tel1 = Range(ColMobile & i).Value
Tel2 = Range(ColDomicile & i).Value
Tel3 = Range(ColTravail & i).Value
If Tel1 <> "" Then
TelGlobal = Tel1
End If
If Tel2 <> "" Then
TelGlobal = Tel2
End If
If Tel3 <> "" Then
TelGlobal = "'" & Tel3
End If
If Tel1 <> "" And Tel2 <> "" Then
TelGlobal = Tel1 & vbCrLf & Tel2
End If
If Tel1 <> "" And Tel3 <> "" Then
TelGlobal = Tel1 & vbCrLf & Tel3
End If
If Tel2 <> "" And Tel3 <> "" Then
TelGlobal = Tel2 & vbCrLf & Tel3
End If
If Tel1 <> "" And Tel2 <> "" And Tel3 <> "" Then
TelGlobal = Tel1 & vbCrLf & Tel2 & vbCrLf & Tel3
End If
Range(ColRgtTel & i) = TelGlobal
Tel1 = Empty
Tel2 = Empty
Tel3 = Empty
TelGlobal = Empty
Next i
'Suppression des ":" parasites
Columns(ColRgtTel).Select
Selection.Replace What:=":", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Suppression des anciennes colonnes mail
Columns(ColMobile & ":" & ColTravail).Delete shift:=xlToLeft
End Sub
Sub AjouteEspace()
Dim AjoutEspace As String
Dim plage As Range, c As Range
Dim nbcarac As Byte
Dim DerLigne As String
DerLigne = Range("A65000").End(xlUp).Row
Set plage = Range("E2:G" & DerLigne)
'Attribue le format "Texte" à la plage des colonnes E, F, G contenant les n° de téléphones
plage.NumberFormat = "@"
For Each c In plage
If c <> "" Then
If Left(c.Value, 1) <> 0 Then
c.Value = "0" & c.Value
End If
AjoutEspace = ChaineEtEspace(c.Value) '(Range("I13").Value)
c = AjoutEspace
End If
Next c
End Sub
Function ChaineEtEspace(xChaine)
Dim F As Integer
Dim xDeux As String
Dim xresult As String
For F = 1 To Len(xChaine) Step 2
xDeux = Mid(xChaine, F, 2)
'xresult = xresult & " " & xDeux 'Pour ajouter une espace avant le 1er caractère
xresult = xresult & xDeux & " " 'Ajoute une espace après le 2° caractère
Next F
'ChaineEtEspace = UCase(RTrim(xresult)) 'Met la chaine de caractères en MAJ et supprime le dernier espace
ChaineEtEspace = RTrim(xresult) 'Supprime le dernier espace
End Function