[Webinar] Streamline your web hosting managementRegister Today

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 103
  • Last Modified:

Macro to remove spaces

Hello,
can you please help with an excel vba to remove spaces and format properly.
Example
COMPANY
STREET
City,   Q C   JOE 1E0

Should be
COMPANY      
STREET      
City, QC JOE1E0      ---- (City COMMA SPACE PROVINCE SPACE POSTALCODE)

Please see attached sample.
Any help is appreciated.
sample2.xlsx
0
W.E.B
Asked:
W.E.B
  • 7
  • 4
  • 3
2 Solutions
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Try this....

Sub RemoveSpaces()
Columns("A:A").Replace What:="  ", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
End Sub

Open in new window

0
 
W.E.BAuthor Commented:
Hi Sudodh,
Thank you very muc,

Is it possible to add an if

if Adjacent cell in Column B = "Add to File"
then  do
Columns("A:A").Replace What:="  ", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

Thanks again,
0
 
Rgonzo1971Commented:
Hi,

pls try

Sub macro()

For Each c In Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
strNewAddress = ""
    If c.Offset(, 1) = "Add to File" Then
        aAddress = Split(c, ",")
        For idx = 1 To Len(aAddress(1))
            strLetter = Mid(aAddress(1), idx, 1)
            If strLetter <> " " Then
                strNewAddress = strNewAddress & strLetter
            End If
        Next
        strNewAddress = " " & Left(strNewAddress, 2) & " " & Right(strNewAddress, Len(strNewAddress) - 3)
        aAddress(1) = strNewAddress
        c.Value = Join(aAddress, ",")
    End If
Next
End Sub

Open in new window

Regards
0
The new generation of project management tools

With monday.com’s project management tool, you can see what everyone on your team is working in a single glance. Its intuitive dashboards are customizable, so you can create systems that work for you.

 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Please try this......
Sub RemoveSpaces()
Dim lr As Long
Dim rng As Range, cell As Range
lr = Cells(Rows.Count, 2).End(xlUp).Row
On Error Resume Next
With ActiveSheet.Rows(1)
   .AutoFilter field:=2, Criteria1:="Add to File"
   If Range("B1:B" & lr).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
      Set rng = Range("A1:A" & lr).SpecialCells(xlCellTypeVisible)
      For Each cell In rng
         cell = WorksheetFunction.Trim(cell.Value)
      Next cell
   End If
   .AutoFilter
End With
End Sub

Open in new window

0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Please try this tweaked code.......
Sub RemoveSpaces()
Dim lr As Long
Dim rng As Range, cell As Range
lr = Cells(Rows.Count, 2).End(xlUp).Row
On Error Resume Next
With ActiveSheet.Rows(1)
   .AutoFilter field:=2, Criteria1:="Add to File"
   If Range("B1:B" & lr).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
      Set rng = Range("A1:A" & lr).SpecialCells(xlCellTypeVisible)
      For Each cell In rng
         cell = WorksheetFunction.Trim(cell.Value)
         cell = WorksheetFunction.Replace(cell.Value, InStrRev(cell.Value, " "), 1, "")
      Next cell
   End If
   .AutoFilter
End With
End Sub

Open in new window

0
 
Rgonzo1971Commented:
pls try

Sub macro()

For Each c In Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
strNewAddress = ""
    If c.Offset(, 1) = "Add to File" Then
        aAddress = Split(c, ",")
        strNewAddress = Replace(aAddress(1), " ", "")
        strNewAddress = " " & Left(strNewAddress, 2) & " " & Right(strNewAddress, Len(strNewAddress) - 3)
        aAddress(1) = strNewAddress
        c.Value = Join(aAddress, ",")
    End If
Next
End Sub

Open in new window

0
 
W.E.BAuthor Commented:
Thank you ,
Rgonzo,

your code is trimming the left letter of the postal code.
Example
ANGEGARDIEN, QC JOE1E0
becomes
ANGEGARDIEN, QC OE1E0

Subodh
Your code is combining province with postalcode
CONTRECOEUR, QC  JOL 1CO
Becomes
CONTRECOEUR, QCJOL 1CO
0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Did you try my latest tweaked code?
It converts CONTRECOEUR, QC  JOL 1CO into CONTRECOEUR, QC  JOL1CO
0
 
W.E.BAuthor Commented:
Hi Sudobh,
I just tried the tweaked code

ROUYNNORANDA,   QC   J9X5E4
Becomes
ROUYNNORANDA, QCJ9X5E4
0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Okay give it a try...

Sub RemoveSpaces()
Dim lr As Long
Dim rng As Range, cell As Range
lr = Cells(Rows.Count, 2).End(xlUp).Row
On Error Resume Next
With ActiveSheet.Rows(1)
   .AutoFilter field:=2, Criteria1:="Add to File"
   If Range("B1:B" & lr).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
      Set rng = Range("A1:A" & lr).SpecialCells(xlCellTypeVisible)
      For Each cell In rng
         If cell <> "" Then
            cell = Replace(cell.Value, Chr(160), " ")
            Do While InStr(cell.Value, "  ") > 0
               cell = Replace(cell.Value, "  ", " ")
            Loop

            If InStr(Right(cell.Value, 6), " ") <> 0 Then
               cell = WorksheetFunction.Replace(cell.Value, InStrRev(cell.Value, " "), 1, "")
            End If
         End If
      Next cell
   End If
   .AutoFilter
End With
End Sub

Open in new window

0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
I have tweaked the code again. :)

Please try the code given below.....
Sub RemoveSpaces()
Dim lr As Long
Dim rng As Range, cell As Range
lr = Cells(Rows.Count, 2).End(xlUp).Row
On Error Resume Next
With ActiveSheet.Rows(1)
   .AutoFilter field:=2, Criteria1:="Add to File"
   If Range("B1:B" & lr).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
      Set rng = Range("A1:A" & lr).SpecialCells(xlCellTypeVisible)
      For Each cell In rng
         If cell <> "" Then
            cell = Replace(cell.Value, Chr(160), " ")
            Do While InStr(cell.Value, "  ") > 0
               cell = Replace(cell.Value, "  ", " ")
            Loop
            cell = WorksheetFunction.Trim(cell.Value)
            If InStr(Right(cell.Value, 6), " ") <> 0 Then
               cell = WorksheetFunction.Replace(cell.Value, InStrRev(cell.Value, " "), 1, "")
            End If
         End If
      Next cell
   End If
   .AutoFilter
End With
End Sub

Open in new window

0
 
Rgonzo1971Commented:
then
trySub macro()

For Each c In Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
strNewAddress = ""
    If c.Offset(, 1) = "Add to File" Then
        aAddress = Split(c, ",")
        For idx = 1 To Len(aAddress(1))
            strLetter = Mid(aAddress(1), idx, 1)
            If strLetter <> " " Then
                strNewAddress = strNewAddress & strLetter
            End If
        Next
        strNewAddress = " " & Left(strNewAddress, 2) & " " & Right(strNewAddress, Len(strNewAddress) - 2)
        aAddress(1) = strNewAddress
        c.Value = Join(aAddress, ",")
    End If
Next
End Sub

Open in new window

0
 
W.E.BAuthor Commented:
Thank you very much guys.
Both worked.
0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You're welcome. Glad to help.
0

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 7
  • 4
  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now