Re: [ExcelVBA] Re: Find Replace of spaces

 

Dear All

My late offering to this thread is the following macro which I wrote about ten years ago and use almost daily to clean up pasted in tables for printing and Vlookups etc. 

In this version I also convert the troublesome 'clever' quote characters to normal quotes and replace double spaces with single because these can be a major cause of Vlookup failure. 

You can modify this easily for other troublesome characters that creep in like the long hyphen, the big dot and the control N carriage return. Just look up the ASCII value.

Note this macro works on the entire spreadsheet but only for cells with Text in them, not formulae. I cannot remember why I use the  .Formula property rather than .Text. There may be a good reason but it works so don't mend it.

Note also that the Replace for double space has to be inside a loop. That  catches people out sometimes.

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

''   Remove leading and trailing spaces from all cells in sheet

''   Convert double spaces to single, convert fancy quote symbols

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub TrimAllCells()

Dim oCell As Range, sHardSpace As String

Const TWOSPACES = "  "

Const SPACE = " "

Dim sOpenQuote As String, sCloseQuote As String

'

    sOpenQuote = Chr(145)

    sCloseQuote = Chr(146)

    sHardSpace = Chr(160)

    Application.ScreenUpdating = False

    For Each oCell In ActiveSheet.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)

        With oCell

            On Error Resume Next ' in case cell has error

                .Formula = Replace(.Formula, sOpenQuote, "'")

                .Formula = Replace(.Formula, sCloseQuote, "'")

                .Formula = Replace(.Formula, sHardSpace, SPACE)

                While InStr(.Formula, TWOSPACES) > 0

                    .Formula = Replace(.Formula, TWOSPACES, SPACE)

                Wend

                .Formula = Trim(.Formula)

            On Error GoTo 0

        End With

    Next oCell

    Application.ScreenUpdating = True

    MsgBox "Done Trim all cells"

End Sub

Enjoy

Derek Turner

England +++

---

From: "Rajiv Pathak rpp31071@yahoo.com [ExcelVBA]" <ExcelVBA@yahoogroups.com>
To: ExcelVBA@yahoogroups.com
Sent: Thursday, 1 June 2017, 15:48
Subject: Re: [ExcelVBA] Re: Find Replace of spaces

 

thaks some time problems are big but the solutions are small 

Rajiv Pathak

On 01-Jun-2017 18:03, "Green 1z@compuserve.com [ExcelVBA]" <ExcelVBA@yahoogroups.com> wrote:

 

Coming to this pretty late.... 

I wonder if this might be useful. It was very useful for me at the time.... I wrote it some time ago :-)

I have an excel version too to dump to a worksheet.

Lisa

Sub subDumpString(strpLine As String, _

    Optional vpLineNum As Variant)

' Dump a string.

Dim intlI As Integer

Dim strlLine As String

Dim intlICols As Integer

Dim intlRows As Integer

Dim objlRange As Object

Dim intlCol As Integer

Dim intlTableNum As Integer

Dim intlRemainder As Integer

Dim intlColsDone As Integer

Dim strlLineNum As String

Dim slChr As String * 1

If IsMissing(vpLineNum) Then

  strlLineNum = "No Line number given"

Else

  strlLineNum = "Line " & Str$(vpLineNum)

End If

intlTableNum = 0

strlLine = strpLine

Documents.Add

Set objlRange = ActiveDocument.Content

With objlRange

  

  Selection.InsertAfter "Line >" & strlLine & "<" & vbCrLf & vbCrLf

  Selection.InsertAfter "Length =" & Len(strlLine) & vbCrLf & vbCrLf

  Selection.InsertAfter strlLineNum & vbCrLf & vbCrLf

  intlI = 1

  intlRows = 1

  intlCol = 12

  Do

    If intlCol > 11 Then

      Selection.EndKey Unit:=wdStory

      Selection.InsertAfter intlI & " To " & intlI + 9 & vbCrLf

      Selection.EndKey Unit:=wdStory

      ActiveDocument.Tables.Add _

          Range:=Selection.Range, _

          NumRows:=3, _

          NumColumns:=11, _

          DefaultTableBehavior:=wdWord9TableBehavior, _

          AutoFitBehavior:=wdAutoFitFixed

          

      Selection.EndKey Unit:=wdStory

      Selection.TypeParagraph

      Selection.TypeParagraph

      intlCol = 2

      intlTableNum = intlTableNum + 1

      ActiveDocument.Tables(intlTableNum) _

          .Cell(1, 1).Range.Text _

          = "Chr"

      ActiveDocument.Tables(intlTableNum) _

          .Cell(2, 1).Range.Text _

          = "Asc"

      ActiveDocument.Tables(intlTableNum) _

          .Cell(3, 1).Range.Text _

          = "Chr #"

      

    End If

    

    

    slChr = Mid$(strlLine, intlI, 1)

    ActiveDocument.Tables(intlTableNum) _

            .Cell(1, intlCol).Range.Text _

            = slChr

    ActiveDocument.Tables(intlTableNum) _

            .Cell(2, intlCol).Range.Text _

            = Asc(slChr)

    ActiveDocument.Tables(intlTableNum) _

            .Cell(3, intlCol).Range.Text _

            = intlI

    

    Selection.Collapse wdCollapseEnd

    intlCol = intlCol + 1

    intlI = intlI + 1

    

  Loop Until intlI > Len(strlLine)

End With

Set objlRange = Nothing

' ***********************************************************************

End Sub

__._,_.___

---

Posted by: Derek Turner <g4swy@yahoo.com>

---

Reply via web post

•

Reply to sender

•

Reply to group

•

Start a New Topic

•

Messages in this topic (16)

---

Have you tried the highest rated email app?

With 4.5 stars in iTunes, the Yahoo Mail app is the highest rated email app on the market. What are you waiting for? Now you can access all your inboxes (Gmail, Outlook, AOL and more) in one place. Never delete an email again with 1000GB of free cloud storage.

---

----------------------------------
Be sure to check out TechTrax Ezine for many, free Excel VBA articles! Go here: http://www.mousetrax.com/techtrax to enter the ezine, then search the ARCHIVES for EXCEL VBA.

----------------------------------
Visit our ExcelVBA group home page for more info and support files:
http://groups.yahoo.com/group/ExcelVBA

----------------------------------
More free tutorials and resources available at:
http://www.mousetrax.com

----------------------------------

Visit Your Group

• Privacy • Unsubscribe • Terms of Use

.

__,_._,___