UltimateCleanSheet Code errors

Question

Trying to write a Clean sheet Sub

First:

Some serial #'s from the data I get will start with - which is a problem in excel, I want to replace all cell content that starts with - and replace it with @ replace() does not work

This is erroring:

.Value = Evaluate("if(row(" & .Address & "),""@"" & Right(" & .Address & ", Len(" & .Address & ") - 2))")

It turns all cells to #NAME?

2nd:

I Changed this

 MyArray(x, y) = RemoveChars(MyArray(x, y)

To this

 If Not IsError(MyArray(x, y)) Then
         MyArray(x, y) = RemoveChars(MyArray(x, y))
 End If

Because the code ran (Sans the line of code from Question 1) the first time but if I ran it a second time on the same data sheet it errored

What would cause the code to error on the second run?

Does adding the If Not IsError(MyArray(x, y)) interfere with the removal of unwanted characters?

The UDF came from Here:

Alter code to Remove instead of Allow characters

Sub UltimateCleanSheet()
Dim HL As Hyperlink
Dim MyArray As Variant
Dim ws As Worksheet
Dim CL As Range
Dim txt As String
Dim LastRow As Long, LastCol As Long, x As Long, y As Long

goFast False
For Each ws In Worksheets(Array("OriginalData", "NewData"))
 With ws

      'Get error if sheet not selected
      ws.Select

      'Reset UsedRange
      Application.ActiveSheet.UsedRange

      'Create Array
      MyArray = ws.UsedRange.Offset(1, 0)

     'Remove unwanted Characters
     'http://www.ascii-code.com/
     For x = LBound(MyArray) To UBound(MyArray)
         For y = LBound(MyArray, 2) To UBound(MyArray, 2)

         If Not IsError(MyArray(x, y)) Then
               MyArray(x, y) = RemoveChars(MyArray(x, y))
         End If

         Next y
     Next x

    'Postback to sheet
    .UsedRange.Offset(1, 0) = MyArray
 End With

 With ws.UsedRange.Offset(1, 0)

    'Clear all formulas
    .Value = .Value

    'Replace "Non-breaking space" with ""
    .Replace what:=Chr(160), replacement:=vbNullString, lookat:=xlPart

    'Replace carriage Return with ", "
    .Replace what:=Chr(13), replacement:=", ", lookat:=xlPart

    'Replace hyphen if 1st char with "@"
    .Value = Evaluate("if(row(" & .Address & "),""@"" & Right(" & .Address & ", Len(" & .Address & ") - 2))")

    'Clean, Trim
    .Value = Evaluate("if(row(" & .Address & "),clean(trim(" & .Address & ")))")
End With

'Turn live hyperlinks to text
For Each HL In ws.Hyperlinks
    Set CL = HL.Parent
    txt = HL.Address & HL.SubAddress
    HL.Delete
    CL.Value = txt
Next HL

Next ws

ThisWorkbook.Sheets(1).Select
goFast True
End Sub

UDF:

Function RemoveChars(ByVal strSource As String) As String
Dim i As Integer
Dim strResult As String

For i = 1 To Len(strSource)
    Select Case Asc(Mid(strSource, i, 1))
        Case 0, 9, 10, 12, 33, 161 To 255:

        Case Else:
            strResult = strResult & Mid(strSource, i, 1)

    End Select
Next i

RemoveChars = strResult

End Function

Did you try `ws.UsedRange.Replace What:="-", Replacement:="'@", LookAt:=xlPart` (or `Replacement:="""@"""`) — paul bica, Aug 26 '15 at 18:04
`aCell` was a mistake I have changed my code to reflect this. Sorry about that, still errors — xyz, Aug 26 '15 at 18:13

xyz · Accepted Answer · 2015-09-12T02:59:41.547

After much ado I came up with

Edit Addition and improvment

'Sheet Names To Clean
'ID Column Number
'Name (e.g John Doe) Column Number
'Dilimiter to Replace carriage Returns with
Sub CleanSheets()

  fCleanSheets Array("Elements", "Connections"), 1, 2, ", "

End Sub

Sub:

Sub fCleanSheets(arrShtNames As Variant, IdColNub As Long, LabelColNub As Long,   Optional iDiliter As String = ", ")
Dim HL As Hyperlink
Dim MyArray As Variant
Dim ws As Worksheet
Dim CL As Range, Rng, aCell As Range
Dim txt As String
Dim x As Long, y As Long

For Each ws In Worksheets(arrShtNames)
 With ws
  'IF Get error if sheet not selected then uncomment
  'ws.Select

  'Reset UsedRange
  Application.ActiveSheet.UsedRange

  'TextWrap
   Application.ActiveSheet.UsedRange.WrapText = False

  'Turn live hyperlinks to text
  For Each HL In ws.Hyperlinks
    Set CL = HL.Parent
    txt = HL.Address & HL.SubAddress
    HL.Delete
    CL.Value = txt
  Next HL

  'Remove all Formulas
  With ws.UsedRange.Offset(1, 0)
    .Value = .Value
  End With

  'Create Array
  MyArray = .UsedRange.Offset(1, 0)

 For x = LBound(MyArray) To UBound(MyArray)
     For y = LBound(MyArray, 2) To UBound(MyArray, 2)

     If Not IsError(MyArray(x, y)) Then

         'Remove unwanted Characters
         'http://www.ascii-code.com/
           MyArray(x, y) = RemoveChars_NEWHAB(MyArray(x, y))

         'Trim Sheets(Will NOT error if LEN(string) > 255 char's)
           MyArray(x, y) = Trim(MyArray(x, y))

         'Replace carriage Return with dilimiter
           MyArray(x, y) = Replace(MyArray(x, y), Chr(13), iDiliter)
           MyArray(x, y) = Replace(MyArray(x, y), Chr(10), iDiliter)

     End If

     Next y

     'ONLY APPLYING ON CERTIN COLUMNS
        'If FIRST char = "-" Replace it on ID Column ONLY
           If Left(MyArray(x, IdColNub), 1) = "-" Then
              MyArray(x, IdColNub) = "@" & Right(MyArray(x, IdColNub), Len(MyArray(x, IdColNub)) - 1)
           End If

        'Convert Accented letters to NON Accented letters on Label Column ONLY
          MyArray(x, LabelColNub) = ConvertAccent(MyArray(x, LabelColNub))

        'Remove Mulutiple Spaces Between Names on Label Column ONLY
          MyArray(x, LabelColNub) =  Application.WorksheetFunction.Trim(MyArray(x, LabelColNub))

 Next x

'Postback to sheet
.UsedRange.Offset(1, 0) = MyArray
End With

Next ws

ThisWorkbook.Sheets(1).Select

End Sub

UDF: RemoveChars

Function RemoveChars(ByVal strSource As String) As String
'http://stackoverflow.com/questions/15723672/how-to-remove-all-non-alphanumeric-characters-from-a-string-except-period-and-sp
Dim i As Integer
Dim strResult As String

For i = 1 To Len(strSource)
    Select Case Asc(Mid(strSource, i, 1))
        Case 2, 0, 9, 10, 12, 160, 161 To 255: 'http://www.ascii-code.com/

        Case Else:
            strResult = strResult & Mid(strSource, i, 1)

    End Select
Next i

RemoveChars = strResult

End Function

UDF: ConvertAccent

 Function ConvertAccent(ByVal inputString As String) As String
 ' http://www.vbforums.com/archive/index.php/t-483965.html
 Dim x As Long, Position As Long
 Const AccChars As String = _
    "ŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïðñòóôõöùúûüýÿ"
 Const RegChars As String = _
    "SZszYAAAAAACEEEEIIIIDNOOOOOUUUUYaaaaaaceeeeiiiidnooooouuuuyy"
 For x = 1 To Len(inputString)
   Position = InStr(AccChars, Mid(inputString, x, 1))
   If Position Then Mid(inputString, x) = Mid(RegChars, Position, 1)
Next
ConvertAccent = inputString
End Function

UltimateCleanSheet Code errors

1 Answers1