Sub Macro2()
'
' Macro2 Macro
'
' Réalisé par Thierry
Set VariableObjet = Nothing
' vide press papier'
Application.CutCopyMode = False
Application.ScreenUpdating = False
' variables pour séparation num de la rue
Dim FL1 As Worksheet, Cell As Range, Plage As Range
Dim Var0, Var1, Var2, Var3, Var4, Var5, Adresse, Cible, EtatBac As String
Dim i, fin As Integer
'
UserForm1.Show 0
DoEvents
' Touche de raccourci du clavier: Ctrl+k
' Importation : le classeur export.xls doit être ouvert
Call importation
' Numéro de ligne import
i = 2
fin = Range("A2", Selection.End(xlDown)).Cells.Count ' fin de fichier d'exportation
Set FL1 = Worksheets("Feuil1")
With FL1
'Détermination de la plage de cellules à lire
Set Plage = .Range("E2" & ":" & "E" & fin)
' Insert colonne Numéro Rue pour modification de chaine caractères Adresse
Columns("E:E").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.ColumnWidth = 6.3
Columns("F:F").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.ColumnWidth = 4
For Each Cell In Plage
'Valeur de la cellule lue
Adresse = Cell.Value
Var0 = Cell.Value
Var0 = Mid(Var0, 1, 1)
Var1 = Cell.Value
Var1 = Mid(Var1, 1, 2)
Var2 = Cell.Value
Var2 = Mid(Var2, 1, 3)
Var3 = Cell.Value
Var3 = Mid(Var3, 1, 4)
Var4 = Cell.Value
Var4 = Mid(Var4, 1, 5)
Var5 = Cell.Value
Var5 = Mid(Var5, 1, 6)
EtatBac = Cell.Value
EtatBac = Worksheets("Feuil1").Range("I" & i)
' **********************************************
' Traitement sur zone ou place de numéros de rue
' **********************************************
If Val(Mid(Adresse, 1, 1)) > 0 And Val(Mid(Adresse, 3, 1)) > 0 And Val(Mid(Adresse, 5, 1)) > 0 _
And Mid(Adresse, 2, 1) = " " And Mid(Adresse, 4, 1) = " " And Mid(Adresse, 6, 1) = " " Then
Cells(i, "E").NumberFormat = "####" ' conserver Format Texte
Worksheets("Feuil1").Range("E" & i) = Mid(Adresse, 1, 1) & " -" & Mid(Adresse, 3, 1) & " -" & Mid(Adresse, 5, 1)
Adresse = Right(Adresse, Len(Adresse) - 6)
Adresse = LTrim(Adresse)
Worksheets("Feuil1").Range("G" & i) = Adresse
End If
' ****************************************************
' Traitement valeur normale numéro rue à 1 chriffre
' ****************************************************
If (Val(Var0) > 0 And Val(Var0) <= 9) And Mid(Adresse, 2, 1) = " " Then
Cells(i, "E").NumberFormat = "####" ' conserver Format num
Worksheets("Feuil1").Range("E" & i) = Var1
Adresse = Replace(Adresse, Var1, "")
Adresse = LTrim(Adresse)
Worksheets("Feuil1").Range("G" & i) = Adresse
' Traitement si B pour Bis sur numéro à 1 chiffre
If Mid(Adresse, 1, 2) = "B " Or Mid(Adresse, 1, 2) = "C " Or Mid(Adresse, 1, 2) = "D " _
Or Mid(Adresse, 1, 2) = "E " Or Mid(Adresse, 1, 2) = "F " Or Mid(Adresse, 1, 2) = "G " _
Or Mid(Adresse, 1, 2) = "H " Or Mid(Adresse, 1, 2) = "I " Or Mid(Adresse, 1, 2) = "Q " _
Or Mid(Adresse, 1, 2) = "T " Or Mid(Adresse, 1, 2) = "A " Or Mid(Adresse, 1, 2) = "J " _
Or Mid(Adresse, 1, 2) = "2 " Or Mid(Adresse, 1, 2) = "3 " Or Mid(Adresse, 1, 2) = "4 " _
Or Mid(Adresse, 1, 2) = "5 " Or Mid(Adresse, 1, 2) = "6 " Or Mid(Adresse, 1, 2) = "7 " _
Or Mid(Adresse, 1, 2) = "8 " Or Mid(Adresse, 1, 2) = "9 " Or Mid(Adresse, 1, 2) = "B-" Then
Cells(i, "E").NumberFormat = "####" ' conserver Format num
Worksheets("Feuil1").Range("E" & i) = Var1
Worksheets("Feuil1").Range("F" & i) = Mid(Adresse, 1, 1)
Adresse = Right(Adresse, Len(Adresse) - 1)
Adresse = LTrim(Adresse)
Worksheets("Feuil1").Range("G" & i) = Adresse
End If
' Traitement si Bis ou Ter sur numro à 1 chiffre
If Mid(Adresse, 1, 3) = "BIS" Or Mid(Adresse, 1, 3) = "TER" Or Mid(Adresse, 1, 3) = "B/T" _
Or Mid(Adresse, 1, 3) = "Bis" Or Mid(Adresse, 1, 3) = "Ter" Then
Cells(i, "E").NumberFormat = "####" ' conserver Format num
Worksheets("Feuil1").Range("E" & i) = Var1
Worksheets("Feuil1").Range("F" & i) = Mid(Adresse, 1, 3)
Adresse = Right(Adresse, Len(Adresse) - 3)
Adresse = LTrim(Adresse)
Worksheets("Feuil1").Range("G" & i) = Adresse
End If
Else
' ***********************************************
' Traitement valeur normale numéro à 2 chiffres
' ***********************************************
If Val(Var1) >= 10 And Mid(Adresse, 3, 1) = " " Then
Cells(i, "E").NumberFormat = "####" ' conserver Format num
Worksheets("Feuil1").Range("E" & i) = Var1
Adresse = Replace(Adresse, Var1, "")
Adresse = LTrim(Adresse)
Worksheets("Feuil1").Range("G" & i) = Adresse
' Traitement si B pour Bis sur numéro à 2 chiffres
If Mid(Adresse, 1, 2) = "B " Or Mid(Adresse, 1, 2) = "C " Or Mid(Adresse, 1, 2) = "D " _
Or Mid(Adresse, 1, 2) = "E " Or Mid(Adresse, 1, 2) = "F " Or Mid(Adresse, 1, 2) = "G " _
Or Mid(Adresse, 1, 2) = "H " Or Mid(Adresse, 1, 2) = "I " Or Mid(Adresse, 1, 2) = "Q " _
Or Mid(Adresse, 1, 2) = "T " Or Mid(Adresse, 1, 2) = "A " Or Mid(Adresse, 1, 2) = "J " _
Or Mid(Adresse, 1, 2) = "2 " Or Mid(Adresse, 1, 2) = "3 " Or Mid(Adresse, 1, 2) = "4 " _
Or Mid(Adresse, 1, 2) = "5 " Or Mid(Adresse, 1, 2) = "6 " Or Mid(Adresse, 1, 2) = "7 " _
Or Mid(Adresse, 1, 2) = "8 " Or Mid(Adresse, 1, 2) = "9 " Or Mid(Adresse, 1, 2) = "B-" Then
Cells(i, "E").NumberFormat = "####" ' conserver Format num
Worksheets("Feuil1").Range("E" & i) = Var1
Worksheets("Feuil1").Range("F" & i) = Mid(Adresse, 1, 1)
Adresse = Right(Adresse, Len(Adresse) - 2)
Adresse = LTrim(Adresse)
Worksheets("Feuil1").Range("G" & i) = Adresse
End If
' Traitement si Bis ou Ter sur numro à 2 chiffres
If Mid(Adresse, 1, 3) = "BIS" Or Mid(Adresse, 1, 3) = "TER" Or Mid(Adresse, 1, 3) = "B/T" _
Or Mid(Adresse, 1, 3) = "Bis" Or Mid(Adresse, 1, 3) = "Ter" Then
Cells(i, "E").NumberFormat = "####" ' conserver Format num
Worksheets("Feuil1").Range("E" & i) = Var1
Worksheets("Feuil1").Range("F" & i) = Mid(Adresse, 1, 3)
Adresse = Right(Adresse, Len(Adresse) - 4)
Adresse = LTrim(Adresse)
Worksheets("Feuil1").Range("G" & i) = Adresse
End If
End If
' *******************************************
' Traitement de numéro de rue à 3 chiffres
' *******************************************
If (Val(Var2) > 99 And Val(Var2) <= 999) And Mid(Adresse, 4, 1) = " " Then
Cells(i, "E").NumberFormat = "####" ' conserver Format num
Worksheets("Feuil1").Range("E" & i) = Var2
Adresse = Right(Adresse, Len(Adresse) - 3)
Adresse = LTrim(Adresse)
Worksheets("Feuil1").Range("G" & i) = Adresse
' Traitement si B pour Bis sur numéro à 3 chiffres
If Mid(Adresse, 1, 2) = "B " Or Mid(Adresse, 1, 2) = "C " Or Mid(Adresse, 1, 2) = "D " _
Or Mid(Adresse, 1, 2) = "E " Or Mid(Adresse, 1, 2) = "F " Or Mid(Adresse, 1, 2) = "G " _
Or Mid(Adresse, 1, 2) = "H " Or Mid(Adresse, 1, 2) = "I " Or Mid(Adresse, 1, 2) = "Q " _
Or Mid(Adresse, 1, 2) = "T " Or Mid(Adresse, 1, 2) = "A " Then
Cells(i, "E").NumberFormat = "####" ' conserver Format num
Worksheets("Feuil1").Range("E" & i) = Var1
Worksheets("Feuil1").Range("F" & i) = Mid(Adresse, 1, 1)
Adresse = Right(Adresse, Len(Adresse) - 2)
Adresse = LTrim(Adresse)
Worksheets("Feuil1").Range("G" & i) = Adresse
End If
' Traitement si Bis ou Ter sur numro à 3 chiffres
If Mid(Adresse, 1, 3) = "BIS" Or Mid(Adresse, 1, 3) = "TER" Or Mid(Adresse, 1, 3) = "B/T" _
Or Mid(Adresse, 1, 3) = "Bis" Or Mid(Adresse, 1, 3) = "Ter" Then
Cells(i, "E").NumberFormat = "####" ' conserver Format num
Worksheets("Feuil1").Range("E" & i) = Var1
Worksheets("Feuil1").Range("F" & i) = Mid(Adresse, 1, 3)
Adresse = Right(Adresse, Len(Adresse) - 4)
Adresse = LTrim(Adresse)
Worksheets("Feuil1").Range("G" & i) = Adresse
End If
End If
' ***************************************
' Traitement numéro de rue à 4 chiffres
' ***************************************
If Val(Var3) >= 1000 And Mid(Adresse, 5, 1) = " " Then
Cells(i, "E").NumberFormat = "####" ' conserver Format num
Worksheets("Feuil1").Range("E" & i) = Var4
Adresse = Right(Adresse, Len(Adresse) - 4)
Adresse = LTrim(Adresse)
Worksheets("Feuil1").Range("G" & i) = Adresse
End If
' Si le dernier caractère égal - alors supprime -
If Mid(Adresse, 1, 1) = "-" Then
Adresse = Right(Adresse, Len(Adresse) - 1)
Adresse = LTrim(Adresse)
Worksheets("Feuil1").Range("G" & i) = Adresse
End If
End If
' Centre le numéro de rue à droite
Worksheets("Feuil1").Range("F" & i).Select
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
i = i + 1
Next
End With
Unload UserForm1
Columns("L:L").Hidden = True
' Tri multi critères (Communes + Adresses + Num Rues + Producteurs )
Call TriBacs
' Préparation de l'impression
Call Imprimer
Set FL1 = Nothing
Set Plage = Nothing
End Sub