Is there a shorter, faster, better way to do the following? It works but it is a lot of code.

[VectorW2]

I have some code in a private sub, In column D, column D is the street address. We get these addresses in every which way and need the address as uniform as possible. So the VBA code addresses some formatting. Is there a better way? What I have is effective, but the code is too long. Thanks in advance.

 

[Sam_D_Ben]

Something like this,

Private Sub FormatAddresses()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Change to your sheet name

    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row ' Find last row in column D

    Dim replacements As Variant
    replacements = Array( _
        Array("Alley", "Ally"), _
        Array("Avenue", "Ave"), _
        Array("Boulevard", "Blvd"), _
        Array("Circle", "Cir"), _
        Array("Court", "Ct"), _
        Array("Crescent", "Cres"), _
        Array("Drive", "Dr"), _
        Array("East", "E"), _
        Array("Esplanade", "Esp"), _
        Array("Freeway", "Fwy"), _
        Array("Highway", "Hwy"), _
        Array("Lane", "Ln"), _
        Array("North", "N"), _
        Array("Parkway", "Pkwy"), _
        Array("Place", "Pl") _
    )

    Dim i As Long, cell As Range
    For Each cell In ws.Range("D2:D" & lastRow)
        If Not IsEmpty(cell.Value) Then
            For i = LBound(replacements) To UBound(replacements)
                cell.Value = Replace(cell.Value, replacements(i)(0), replacements(i)(1))
            Next i
        End If
    Next cell

    MsgBox "Address formatting complete!", vbInformation
End Sub

 

[DanteAmor]

Write in two columns that you have available on your sheet, let's say columns X and Y, in X you put the name and in Y you put the abbreviation:

varios 06feb2025.xlsm
	X	Y
1	ADDRESS	ABBREVIATION
2	Alley	Ally
3	Avenue	Ave
4	Boulevard	Blvd
5	Circle	Cir
Hoja1

It will even be easier to add or modify elments in the table in the sheet than in the code.

Replace your code with the following:

Sub replace_address()
  Dim c As Range
  For Each c In Range("X2", Range("X" & Rows.Count).End(3))
    Range("D2", Range("D" & Rows.Count).End(xlUp)).Replace c.Value, c.Offset(0, 1).Value, xlPart, xlByRows, False
  Next
End Sub

Change the X to the column you have chosen
For Each c In Range("X2", Range("X" & Rows.Count).End(3))

Note: For the future, it would be helpful if you could provide us with the code within the code tags, instead of an image.

 

[VectorW2]

Something like this,

Private Sub FormatAddresses()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Change to your sheet name

    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row ' Find last row in column D

    Dim replacements As Variant
    replacements = Array( _
        Array("Alley", "Ally"), _
        Array("Avenue", "Ave"), _
        Array("Boulevard", "Blvd"), _
        Array("Circle", "Cir"), _
        Array("Court", "Ct"), _
        Array("Crescent", "Cres"), _
        Array("Drive", "Dr"), _
        Array("East", "E"), _
        Array("Esplanade", "Esp"), _
        Array("Freeway", "Fwy"), _
        Array("Highway", "Hwy"), _
        Array("Lane", "Ln"), _
        Array("North", "N"), _
        Array("Parkway", "Pkwy"), _
        Array("Place", "Pl") _
    )

    Dim i As Long, cell As Range
    For Each cell In ws.Range("D2:D" & lastRow)
        If Not IsEmpty(cell.Value) Then
            For i = LBound(replacements) To UBound(replacements)
                cell.Value = Replace(cell.Value, replacements(i)(0), replacements(i)(1))
            Next i
        End If
    Next cell

    MsgBox "Address formatting complete!", vbInformation
End Sub

This works great for the street types and direction, but how do I remove the special characters ".", ",", "-", "#" and extra spaces?

 

[VectorW2]

Write in two columns that you have available on your sheet, let's say columns X and Y, in X you put the name and in Y you put the abbreviation:

varios 06feb2025.xlsm
	X	Y
1	ADDRESS	ABBREVIATION
2	Alley	Ally
3	Avenue	Ave
4	Boulevard	Blvd
5	Circle	Cir
Hoja1

It will even be easier to add or modify elments in the table in the sheet than in the code.

Replace your code with the following:

Sub replace_address()
  Dim c As Range
  For Each c In Range("X2", Range("X" & Rows.Count).End(3))
    Range("D2", Range("D" & Rows.Count).End(xlUp)).Replace c.Value, c.Offset(0, 1).Value, xlPart, xlByRows, False
  Next
End Sub

Change the X to the column you have chosen
For Each c In Range("X2", Range("X" & Rows.Count).End(3))

Note: For the future, it would be helpful if you could provide us with the code within the code tags, instead of an image.

I have two columns on another sheet (Dropdown) in this workbook that are similar to what I think you are telling me. I am having trouble making this work though. What information do you need from me?

 

[DanteAmor]

Replace Sheet1 with the name of the sheet where you have the names and abbreviations.

Replace Sheet2 with the name of the sheet where you are going to make the changes.
(Remember to adjust the X to the column where you have the names...)

Sub replace_address()
  Dim c As Range
  For Each c In Sheets("Sheet1").Range("X2",  Sheets("Sheet1").Range("X" & Rows.Count).End(3))
    Sheets("Sheet2").Range("D2", Sheets("Sheet2").Range("D" & Rows.Count).End(xlUp)).Replace c.Value, c.Offset(0, 1).Value, xlPart, xlByRows, False
  Next
End Sub

What information do you need from me?

All the information concerning your sheets. Names of your sheets, in which columns you have the information, ideally you should add a minisheet, use the XL2BB tool.
That would help if we could help you and not be guessing where your data is.
For now, adjust the macro with my instructions and try.

 

[VectorW2]

I have two columns on another sheet (Dropdown) in this workbook that are similar to what I think you are telling me. I am having trouble making this work though. What information do you need from me?

Thank you.

 

[VectorW2]

Replace Sheet1 with the name of the sheet where you have the names and abbreviations.

Replace Sheet2 with the name of the sheet where you are going to make the changes.
(Remember to adjust the X to the column where you have the names...)

Sub replace_address()
  Dim c As Range
  For Each c In Sheets("Sheet1").Range("X2",  Sheets("Sheet1").Range("X" & Rows.Count).End(3))
    Sheets("Sheet2").Range("D2", Sheets("Sheet2").Range("D" & Rows.Count).End(xlUp)).Replace c.Value, c.Offset(0, 1).Value, xlPart, xlByRows, False
  Next
End Sub

All the information concerning your sheets. Names of your sheets, in which columns you have the information, ideally you should add a minisheet, use the XL2BB tool.
That would help if we could help you and not be guessing where your data is.
For now, adjust the macro with my instructions and try.

Thank you! This is great. Thanks again.