Partager via

separer n° et nom des rue

Anonyme
2020-09-02T08:44:42+00:00

Bonjour a toutes et tous,

merci de lire mon post

je tente de séparer le numéro et la rue d'une adresse dans 2 cellules.

j ai un fichier excel avec ce type d'adresse

1 Place Roger Salengro

Espace du foot Des 4 Chemins 7 Route Varton

24 Rue Egalité

Entrée C 1 Rue Four

j'utilise cette macro

' Extraire N° et adresse

Application.ScreenUpdating = False

[D2].FormulaR1C1 = _

"=LEFT(RC[1],SUMPRODUCT(ISNUMBER(MID(RC[1],ROW(OFFSET(    R1C1,,,LEN(RC[1]))),1)*1)*1))"

[D2].AutoFill Destination:=Range("D2:D" & Fin)

Range("E2").EntireColumn.Insert

[E2].FormulaR1C1 = "=TRIM(RIGHT(RC[1],LEN(RC[1])-LEN(RC[-1])))"

Range("E2").AutoFill Destination:=Range("E2:E" & Fin)

Range("D2:F" & Fin).Value = Range("D2:F" & Fin).Value

Columns("F:F").Delete

Application.CutCopyMode = False

Application.ScreenUpdating = True

j'ai un problème, sur certaines lignes, ça fonctionne parfaitement et de temps en temps, j ai ce type de resultats

colonne D                          colonne E

Espace                                du foot Des 4 Chemins 7 Route Varton

24 R                                    ue Egalité

Avez vous une idée sur ce qui cause cette erreur ?

en vous remerciant par avance

Microsoft 365 et Office | Excel | Pour la maison | Windows

Question verrouillée. Cette question a été migrée à partir de la Communauté Support Microsoft. Vous pouvez voter pour indiquer si elle est utile, mais vous ne pouvez pas ajouter de commentaires ou de réponses ni suivre la question.

0 commentaires

Réponse acceptée par l’auteur de la question

DanielCo 107.7K Points de réputation
2020-09-03T14:30:41+00:00

C'est une ânerie de VBA. Il transforme le "1 A" en heure (1 AM = 1 heure du matin). Pour éviter ça mets une apostrophe en tête de la cellule ; ça transforme "1 A" en chaîne de texte et VBA n'y touche pas :

C.Offset(, 1) = "'" & C.Offset(, 1) & " " & Split(C.Offset(, 2).Value, " ")(0)

au lieu de :

C.Offset(, 1) = C.Offset(, 1) & " " & Split(C.Offset(, 2).Value, " ")(0)

Daniel

Cette réponse a-t-elle été utile ?

0 commentaires

14 réponses supplémentaires

Trier par : Le plus utile
Le plus utile Les plus récents Les plus anciens
  1. DanielCo 107.7K Points de réputation
    2020-09-02T12:33:11+00:00

    Sinon, avec la macro suivante :

    Sub test()

      Dim C As Range

      For Each C In Range("D1", Cells(Rows.Count, 4).End(xlUp))

        If IsNumeric(Split(C.Value, " ")(0)) Then

          C.Offset(, 1) = Split(C.Value, " ")(0)

          C.Offset(, 2) = Mid(C.Value, InStr(1, C.Value, " ") + 1, 9 ^ 9)

        Else

          C.Offset(, 1) = C.Value

        End If

      Next C

    End Sub

    Avec des données commençant en D1, tu obtiens :

    Je peux fournir le classeur correspondant.

    Daniel

    Cette réponse a-t-elle été utile ?

    0 commentaires
  2. Anonyme
    2020-09-02T12:31:00+00:00

    voici le lien

    https://mon-partage.fr/f/UmuPQpNC/

    merci beaucoup

    Cette réponse a-t-elle été utile ?

    0 commentaires
  3. DanielCo 107.7K Points de réputation
    2020-09-02T12:18:48+00:00

    Aîe ! C'est aussi long que "La guerre et la paix" ! Pour partager un classeur :

    Clique sur https://mon-partage.fr/

    Clique sur "Choisir un fichier", puis sur "Uploader". Quand la fenêtre suivante s'affiche, fais un clic droit sur le "lien de téléchargement" et clique sur "Copier l'adresse du lien" (le libellé de ce message peut varier suivant ton navigateur). Colle ensuite le lien dans a réponse.

    Daniel

    Cette réponse a-t-elle été utile ?

    0 commentaires
  4. Anonyme
    2020-09-02T12:07:11+00:00

    Voici la macro complete

    Sub Mise_en_forme()

    Columns("B:B").Select

    Selection.Cut

    Columns("L:L").Select

    Selection.Insert Shift:=xlToRight

    ' Mise_en_forme_entete Macro

    Columns("A:A").ColumnWidth = 26.29

    Range("A1").Select

    ActiveCell.FormulaR1C1 = "CONTACT"

    Columns("B:B").Select

    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

    Range("B1").Select

    ActiveCell.FormulaR1C1 = "NOM"

    Range("B2").Select

    Columns("B:B").ColumnWidth = 11.43

    Columns("C:C").Select

    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

    Range("C1").Select

    ActiveCell.FormulaR1C1 = "PRENOM"

    Columns("L:L").Select

    Selection.Cut

    Columns("D:D").Select

    Selection.Insert Shift:=xlToRight

    Range("E1").Select

    ActiveCell.FormulaR1C1 = "ADRESSE"

    Columns("F:F").Select

    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

    ActiveCell.FormulaR1C1 = "ADRESSE 2"

    Range("G1").Select

    ActiveCell.FormulaR1C1 = "C.P."

    Columns("I:I").Select

    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

    Range("I1").Select

    ActiveCell.FormulaR1C1 = "CANTON"

    Range("J1").Select

    ActiveCell.FormulaR1C1 = "Tel n°1"

    Range("K1").Select

    ActiveCell.FormulaR1C1 = "Tel n°2"

    Columns("N:N").Select

    Selection.Delete Shift:=xlToLeft

     ' Separer nom et prenom

    Dim dl&, f

    dl = Cells(Rows.Count, 1).End(3).Row

    f = Array("=MID(RC[-1],1,SEARCH("" "",RC[-1]))", "=MID(RC[-2],SEARCH("" "",RC[-2])+1,9^9)")

    [B2:C2].Formula = f: Range("B2:C" & dl).FillDown

    ' Remplacement caracteres speciaux

    Cells.Select

    Selection.Replace What:="é", Replacement:="e", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:="è", Replacement:="e", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:="ë", Replacement:="e", LookAt:=xlPart, _

     SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:="ê", Replacement:="e", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:="â", Replacement:="a", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:="ä", Replacement:="a", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:="ö", Replacement:="o", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:="ô", Replacement:="o", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:="î", Replacement:="i", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:="ï", Replacement:="i", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:="û", Replacement:="u", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:="ü", Replacement:="u", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:="'", Replacement:=" ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:="ç", Replacement:="c", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    ' Remplacement dans adresse

    Columns("E:E").Select

    Selection.Replace What:=" r ", Replacement:=" rue ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" pl ", Replacement:=" place ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" bd ", Replacement:=" boulevard ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" av ", Replacement:=" avenue ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" rte ", Replacement:=" route ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" resid ", Replacement:=" residence ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" res ", Replacement:=" residence ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" all ", Replacement:=" allee ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" doct ", Replacement:=" docteur ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" prof ", Replacement:=" professeur ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" st ", Replacement:=" saint ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" ste ", Replacement:=" sainte ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" mar ", Replacement:=" marechal ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" chem ", Replacement:=" chemin ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" gen ", Replacement:=" general ", LookAt:=xlPart, _

         SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" capit ", Replacement:=" capitaine ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" imp ", Replacement:=" impasse ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" commdt ", Replacement:=" commandant ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" chauss ", Replacement:=" chaussee ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" dr ", Replacement:=" docteur ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" che ", Replacement:=" chemin ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" sq ", Replacement:=" square ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" fbg ", Replacement:=" faubourg ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" crs ", Replacement:=" cours ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" mte ", Replacement:=" montee ", LookAt:=xlPart, _

         SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" pr ", Replacement:=" petite rue ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

     ReplaceFormat:=False

    Selection.Replace What:=" qu ", Replacement:=" quai ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" prom ", Replacement:=" promenade ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" pres ", Replacement:=" president ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    Selection.Replace What:=" chs ", Replacement:=" chaussee ", LookAt:=xlPart, _

    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    ReplaceFormat:=False

    ' Mise en majuscule

     Columns("B:B").Select

    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

    Dim Fin As Long

    Fin = [F65536].End(xlUp).Row

    Application.ScreenUpdating = False

    [B2].FormulaR1C1 = "=UPPER(RC[-1])"

    [B2].AutoFill Destination:=Range("B2:B" & Fin)

    Columns("B:B").Select

    Selection.Copy

    Columns("A:A").Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

    :=False, Transpose:=False

    Columns("B:B").Select

    Application.CutCopyMode = False

     Selection.Delete Shift:=xlToLeft

    Columns("I:I").Select

    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

    Application.ScreenUpdating = False

    [I2].FormulaR1C1 = "=UPPER(RC[-1])"

    [I2].AutoFill Destination:=Range("I2:I" & Fin)

      Columns("I:I").Select

    Selection.Copy

    Columns("H:H").Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

    :=False, Transpose:=False

    Columns("I:I").Select

    Application.CutCopyMode = False

    Selection.Delete Shift:=xlToLeft

    Columns("F:F").Select

    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

    Application.ScreenUpdating = False

    [F2].FormulaR1C1 = "=UPPER(RC[-1])"

    [F2].AutoFill Destination:=Range("F2:F" & Fin)

    Columns("F:F").Select

    Selection.Copy

    Columns("E:E").Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

    :=False, Transpose:=False

    Columns("F:F").Select

    Application.CutCopyMode = False

    Selection.Delete Shift:=xlToLeft

    ' Figer les volets et filtrer

    Rows("2:2").Select

    With ActiveWindow

    .SplitColumn = 0

    .SplitRow = 1

    End With

    ActiveWindow.FreezePanes = True

    Range("A1:M1").Select

    Range("M1").Activate

    Selection.AutoFilter

    ' deplacement E vers F Macro

    Columns("E:E").Select

    Selection.Copy

    Columns("F:F").Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

    :=False, Transpose:=False

    Columns("E:E").Select

    Application.CutCopyMode = False

    Selection.ClearContents

    Range("E1").Select

    ActiveCell.FormulaR1C1 = "NUMERO"

    Range("E2").Select

    ' canton Macro

    Range("F1").Select

    ActiveCell.FormulaR1C1 = "ADRESSE"

    [I2].FormulaR1C1 = "=VLOOKUP(RC[-1],Feuil1!R1C1:R872C2,2,FALSE)"

    [I2].AutoFill Destination:=Range("I2:I" & Fin)

    ' Renommer cellule A1

    Range("A1").Select

    ActiveCell.FormulaR1C1 = "CONTACT"

    Range("A2").Select

     ' Renommer cellule h1

    Range("H1").Select

    ActiveCell.FormulaR1C1 = "VILLE"

    Range("H2").Select

    ' Supprimer colonne E

    Columns("E").Select

    Selection.Delete Shift:=xlToLeft

    ' Extraire N° et adresse

    Application.ScreenUpdating = False

    [D2].FormulaR1C1 = _

    "=LEFT(RC[1],SUMPRODUCT(ISNUMBER(MID(RC[1],ROW(OFFSET(    R1C1,,,LEN(RC[1]))),1)*1)*1))"

    [D2].AutoFill Destination:=Range("D2:D" & Fin)

    Range("E2").EntireColumn.Insert

    [E2].FormulaR1C1 = "=TRIM(RIGHT(RC[1],LEN(RC[1])-LEN(RC[-1])))"

    Range("E2").AutoFill Destination:=Range("E2:E" & Fin)

    Range("D2:F" & Fin).Value = Range("D2:F" & Fin).Value

    Columns("F:F").Delete

    Application.CutCopyMode = False

    Application.ScreenUpdating = True

    ' Renommer cellule D1 et E1

    Range("D1").Select

    ActiveCell.FormulaR1C1 = "NUM"

    Range("D2").Select

    Range("E1").Select

    ActiveCell.FormulaR1C1 = "RUE"

    Range("E2").Select

    End Sub

    Cette réponse a-t-elle été utile ?

    0 commentaires