Small snag with non-alphanumeric replacements

[funkykizzy]

Hi all!

I was to change "[" and "]" in the same cell to "-". However, my code does not seem to be able to replace the second bracket in the same string.

My Code:

Sub DataParseSVOC()
'
' Routine for parsing 2008-2009 UATMP SVOC data
'
Dim LR As Long
Dim Itm As Long
Dim MyCount As Long
Dim vCol As Long
Dim ws As Worksheet
Dim MyArr As Variant
Dim MyArr2 As Variant
Dim vTitles As String
Dim aFind As Variant
Dim aReplace As Variant
aFind = Array("[", "]")
aReplace = Array("-", "-")
 
Application.ScreenUpdating = False
 
'Column to evaluate from, column A = 1, B = 2, etc.
   vCol = 3
 
'Sheet with data in it
   Set ws = Sheets("SVOC")
 
'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
    vTitles = "A1:M1"
 
'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row
 
'Get a temporary list of unique values from column vCol
      ws.Columns(vCol).SpecialCells(xlConstants).AdvancedFilter _
        Action:=xlFilterCopy, CopyToRange:=ws.Range("P1"), Unique:=True
 
'Create a separate list for worksheet tab names and remove special characters
      ws.Columns(vCol).SpecialCells(xlConstants).AdvancedFilter _
        Action:=xlFilterCopy, CopyToRange:=ws.Range("Q1"), Unique:=True
 
      ws.Columns("Q:Q").Replace What:=aFind, Replacement:=aReplace, LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
'Sort the temporary lists
    ws.Columns("P:P").Sort Key1:=ws.Range("P2"), _
        Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _
        MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
 
    ws.Columns("Q:Q").Sort Key1:=ws.Range("Q2"), _
        Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _
        MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
'Put list into an array for looping
'(values cannot be the result of formulas, must be constants)
    MyArr = Application.WorksheetFunction.Transpose(ws.Range("P1:P" _
        & Rows.Count).SpecialCells(xlCellTypeConstants))
 
    MyArr2 = Application.WorksheetFunction.Transpose(ws.Range("Q1:Q" _
        & Rows.Count).SpecialCells(xlCellTypeConstants))
'clear temporary worksheet list
    ws.Range("P:P").Clear
    ws.Range("Q:Q").Clear
'Turn on the autofilter, one column only is all that is needed
    ws.Range(vTitles).AutoFilter
'Loop through list one value at a time
'The array includes the title cell, so we start at the second value in the array
'In case values are numerical, we convert them to text with ""
    For Itm = 2 To UBound(MyArr)
        ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm) & ""
 
        If Not Evaluate("=ISREF('" & MyArr(Itm) & "'!A1)") Then    'create sheet if needed
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr2(Itm) & ""
        Else                                                      'clear sheet if it exists
            Sheets(MyArr2(Itm) & "").Move After:=Sheets(Sheets.Count)
            Sheets(MyArr2(Itm) & "").Cells.Clear
        End If
 
        ws.Range("A" & Range(vTitles).Resize(1, 1) _
            .Row & ":A" & LR).EntireRow.Copy Sheets(MyArr2(Itm) & "").Range("A1")
 
        ws.Range(vTitles).AutoFilter Field:=vCol
        MyCount = MyCount + Sheets(MyArr2(Itm) & "") _
            .Range("A" & Rows.Count).End(xlUp).Row - 1
        Sheets(MyArr2(Itm) & "").Columns.AutoFit
    Next Itm
 
'Cleanup
    ws.AutoFilterMode = False
    MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " _
                & MyCount & vbLf & "Hope they match!!"
Application.ScreenUpdating = True
End Sub

And the result:

Original = Cyclopenta[cd]pyrene
Macro Result = Cyclopenta-cd]pyrene
Desired = Cyclopenta-cd-pyrene

Any thoughts/suggestions!!

Thank you so much in advance!

 

[funkykizzy]

Anyone? Please? I hate to beg, but I was hoping this was something small that I had overlooked...

Thank you!

 

[pgc01]

Hi

Dim aFind As Variant
Dim aReplace As Variant

aFind = Array("[", "]")
aReplace = Array("-", "-")
 
' ...
      ws.Columns("Q:Q").Replace What:=[COLOR=red][B]aFind[/B][/COLOR], Replacement:=[B][COLOR=red]aReplace[/COLOR][/B], LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False

The replace method of the range object replaces a string with another string, not an array with another array.

You have to loop through the arrays and use .Replace() for each of the string pairs.

 

[shg]

Separating all the other stuff you're doing, you could have a small sub that does the find and replace on a range:

Sub ReplaceBrackets(r As Range)
    Dim cell        As Range
 
    For Each cell In r
        With cell
            If Not .HasFormula(.Cells) And VarType(.Value) = vbString Then
                If .Value Like "*
[*]*" Then
                    .Value = Replace(Replace(.Value, "[", "-"), "]", "-")
                End If
            End If
        End With
    Next cell
End Sub

E.g.,

    ReplaceBrackets Range("A1:A10")

 

[funkykizzy]

Thank you both so much! shg4421, I am going to give your suggestion a try right now...

Much obliged!

 

[funkykizzy]

Hi again!

I gave your suggestion a try and I got a type mismatch error. So I did a bunch of debugging but I still couldn't get the code to run smoothly. For now I might just write everything out each character at a time to meet my deadline, but in the future it would be nice to specify an array of characters to be replaced with another array of characters in the cell contents of a particular row.

Cheers!!

 

[pgc01]

Hi

As I said you could also loop through the arrays:

...
Dim aFind As Variant
Dim aReplace As Variant
[COLOR=red]Dim j As Long[/COLOR]
 
aFind = Array("[", "]")
aReplace = Array("-", "-")
 
' ...
      
[COLOR=red]For j = LBound(aFind) To UBound(aFind)
[/COLOR]      ws.Columns("Q:Q").Replace What:=aFind[COLOR=red](j)[/COLOR], Replacement:=aReplace[COLOR=red](j)[/COLOR], LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
[COLOR=red]Next j
[/COLOR]

 

[funkykizzy]

Thanks PGC!

That is exactly what I am currently working on (well, until I was interrupted by another project, but I am back at it now).

I will let you know if I can get it to work out.

 

[funkykizzy]

Still getting an error. This time it is Run-Time 424 "Object Required". I am trying to debug and see if I am not calling this code right or if I failed to identify something...but still no luck.

 

[pgc01]

Maybe this sub helps your debug.

It replaces all "[" and "]" with "-" in column Q of the active worksheet.

Try and see if you get any error:

Sub Test()
Dim ws As Worksheet
Dim aFind As Variant
Dim aReplace As Variant
Dim j As Long
 
Set ws = ActiveSheet
aFind = Array("[", "]")
aReplace = Array("-", "-")
            
For j = LBound(aFind) To UBound(aFind)
      ws.Columns("Q:Q").Replace What:=aFind(j), Replacement:=aReplace(j), LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
Next j
End Sub