Need Help optimizing a searching/tagging application in Excel

[ruperman]

Hi,

I'm writing a vba script where I insert a list of Strings into an Excel file. Then I need to search each of those strings for certain characters (ie. "&", "'"). When a match is found, it copies the string to the adjacent column and concatenates a tagged alternate spelling to is as well. For example, Column A had these two values:

Rock & Roll
Breakfast @ Night
Tiffany's

The output of the program should be this (where A and B are adjacent Columns):

A
Rock & Roll
Breakfast @ Night
Tiffany's

B
Rock & Roll <!Rock and Roll>
Breakfast @ Night <!Breakfast at Night>
Tiffany's <!Tiffanys>

I have developed a program to do this, but it's slow and doesn't always work right. Here are snippets of my code:

Sub Dupe()

Dim Ess As Integer
Dim X As Integer
Dim Y As Integer
Dim W As Integer
Dim Z As Integer
Dim A1 As Integer
Dim B1 As Integer
Dim C1 As Integer
... 'rest of variables taken out...over 100 of these
Dim AD As String
Dim AE As String
Dim NoTag(5000) As String
Dim Tag(5000) As String
Dim Duplicate(5000) As Integer
Dim Rows As Integer
Dim LastRow As Integer

A = "'"
B = "s "
C = "&"
D = "."
E = "-"
... 'Same as above. over 100 declatations

Worksheets("Output").Activate
For X = 2 To Rows
Ess = 0
Tag(X) = NoTag(X)
Z = Len(NoTag(X))
A1 = InStr(1, NoTag(X), A, vbBinaryCompare)
If A1 > 0 _
Then
Work1 = Left(NoTag(X), (A1 - 1))
Work2 = Right(NoTag(X), (Z - A1))
If InStr((A1 + 1), NoTag(X), "s", vbBinaryCompare) = A1 + 1 _
Then
Tag(X) = Tag(X) & " <!" & Work1 & Work2 & ">"
Ess = 1
End If
If Ess = 0 Then Tag(X) = Tag(X) & " <!" & Work1 & Work2 & ">" & " <!" & Work1 & " " & Work2 & ">"
End If
If A1 = 0 _
Then
B1 = InStr(1, NoTag(X), B, vbBinaryCompare)
If B1 > 0 _
Then
Work1 = Left(NoTag(X), (B1 - 1))
Work2 = Right(NoTag(X), (Z - B1 + 1))
Tag(X) = Tag(X) & " <!" & Work1 & "'" & Work2 & ">"
End If
End If
C1 = InStr(1, NoTag(X), C, vbBinaryCompare)
If C1 > 0 _
Then
... 'This continues until It has searched the cell for each variable.
Cells(X, 1) = Tag(X)
Next X

End Sub

Often, I have over 2,000 cells to search, and I know that there has to be a better way to do this. Any help you can give would be appreciated.

 

[CautionMP]

ruperman,
You have so many variables and math symbols I'm getting a headache just looking at this. With that level of complexity you will have a handful trying to figure out why it doesn't work all the time.

In an effort to simplify the pieces and parts something like this may work for the tagged alternate spelling:

Function AlternateSpelling(OriginalSpelling As String) As String
Dim lngCharacter As Long
Dim strCharactersToRemove As String
Dim strCharactersToReplace As String
Dim strCharacterReplacement() As String
Dim strOutput As String

strCharactersToRemove = "'.-"
strCharactersToReplace = "&@"
'The following string are the replacements for the characters in the preceeding
'string
'NOTE there is an extra comma in front to account for the zero based array
'returned
strCharacterReplacement = Split(",and,at", ",")

'Loop through the entire sting passed to the function
For lngCharacter = 1 To Len(OriginalSpelling)
  'First test is to see if we want to capture the current character
  'i.e. not in strCharactersToRemove
  If InStr(strCharactersToRemove, Mid(OriginalSpelling, lngCharacter, 1)) = 0 Then
    'next check to see if the current character needs to be replaced
    If InStr(strCharactersToReplace, Mid(OriginalSpelling, lngCharacter, 1)) <> 0 Then
      'it does so find it's location and partner in strCharacterReplacement
      strOutput = strOutput & strCharacterReplacement(InStr(strCharactersToReplace, Mid(OriginalSpelling, lngCharacter, 1)))
    Else
      'it does not so return the character
      strOutput = strOutput & Mid(OriginalSpelling, lngCharacter, 1)
    End If
  End If
Next lngCharacter
'Finally check amd see if anything was changed
If OriginalSpelling <> strOutput Then
  AlternateSpelling = "<!" & strOutput & ">"
End If
End Function

Then you could use a simple loop that iterates through your worksheet, calls [tt]AlternateSpelling[/tt] and if it returns text (not "") then place the value in the next column.

Hope this helps,
CMP
P.S. The function can be placed in a worksheet cell, that's what I used for testing purposes. CMP

(GMT-07:00) Mountain Time (US & Canada)