VBA: leading single quote causing errors

[jscranton]

I use the code below to work with large lists of names contained in multiple columns (usually to/from/cc lists). The code works with one minor error related to how Excel reads the single quote (aka apostrophe) as a prefix character.

The code below takes a user selected range and generates a unique list of all values. So, "me;you;him" becomes:

[TABLE="width: 50"]
<tbody>[TR]
[TD]me[/TD]
[/TR]
[TR]
[TD]you[/TD]
[/TR]
[TR]
[TD]him[/TD]
[/TR]
</tbody>[/TABLE]


However, if a selected range contains this value 'somename@somemail.com' then, when transposed, I "lose" the leading apostrophe. So, "me; 'someguy@email.com'; you; him" becomes:

[TABLE="class: grid, width: 50"]
<tbody>[TR]
[TD]me[/TD]
[/TR]
[TR]
[TD]someguy@email.com'[/TD]
[/TR]
[TR]
[TD]you[/TD]
[/TR]
[TR]
[TD]him[/TD]
[/TR]
</tbody>[/TABLE]

For various reasons, I would like to keep the leading apostrophe. What's the easiest way to do such a thing?

Should I turn off Transition Navigation Keys and then loop through to look for anything with a leading apostrophe and change it to "''"?

Thoughts?

Thanks in advance

Option Explicit

Sub GetUniqueListOfNames()


Dim d As Object, i As Long, s, ii As Long
Dim LR As Long
Dim col
Dim rng As Range
Dim a() As Variant


'*************************************************************************************************************************              
'**Assumes Row 1 has headers and column A contains a value in the last used row
'**Prompts user to select columns containing exported name values
'**Assumes names are separated by semi-colon
'**Outputs all unique values onto new worksheet at the end of the workbook sorted alphabetically
'**************************************************************************************************************************




Set rng = Application.InputBox(Prompt:="Select the Columns containing your export names.", Title:="Select Range", Type:=8)


LR = Range("A" & Rows.Count).End(xlUp).Row


ReDim a(1 To LR, 1)




'Create of terms from all selected columns


    For i = 2 To LR
                For Each col In rng.Columns
                    a(i, 1) = CStr(a(i, 1)) & ";" & Cells(i, col.Column).Value & ";"
                Next
                
                a(i, 1) = Replace(CStr(a(i, 1)), ";;", ";")
                a(i, 1) = Replace(CStr(a(i, 1)), "; ", ";")
                a(i, 1) = Trim(CStr(a(i, 1)))
                
    Next i


'Create scripting dictionary and populate with unique values
   
Set d = CreateObject("Scripting.Dictionary")
        For i = LBound(a, 1) To UBound(a, 1)
            If InStr(a(i, 1), ";") = 0 And a(i, 1) <> "" Then
                If Not d.Exists(a(i, 1)) Then
                    d(a(i, 1)) = 1
                End If
            ElseIf InStr(a(i, 1), ";") > 0 Then
                s = Split(a(i, 1), ";")
                    For ii = LBound(s) To UBound(s)
                        If Not d.Exists(s(ii)) Then
                            d(s(ii)) = 1
                        End If
                    Next ii
            End If


        Next i




ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Uniques"


    Cells(1, 1) = "Uniques"
    Range("A2").Resize(d.Count) = Application.Transpose(d.Keys)
    Range("A2:A" & d.Count + 1).Sort key1:=Range("A2"), order1:=1
    Columns(1).AutoFit
    
    
End Sub

 

[Andrew Poulsom]

If you want to retain a leading apostrophe double it up, eg:

''someguy@email.com'

 

[jscranton]

Andrew,

Thanks. The issue is getting VBA to recognize when a text string has a leading apostrophe. Even when I loop through the values with something like:

If Left(ThisWorkbook.Sheets("Uniques").Range("A" & i).Value, 1) = "'" Then

'add another apostrophe
End if

VBA doesn't recognize the leading apostrophe.

I have also tried adding this first: Application.TransitionNavigKeys = False

Thanks,

j

 

[Andrew Poulsom]

I meant add the extra single quote manually. To check if a cell has a leading single quote (with TransitionNavigKeys set to False) you can use its PrefixCharacter property.

 

[jscranton]

Thanks.

This solved it (where LR is the last row of the unique name list):

 For i = 2 To LR 
    If ThisWorkbook.Sheets("Uniques").Range("A" & i).PrefixCharacter = "'" Then
        ThisWorkbook.Sheets("Uniques").Range("A" & i).Value = "''" & ThisWorkbook.Sheets("Uniques").Range("A" & i).Value
    End If
 
 Next i