如何使用 VBA 定义单元格中的字符是数字、字母还是特殊字符？

Question

我想遍历一个包含数字、字母和其他不同长度字符的单元格的列，并在第二行中对该单元格的“模板”进行排序。

数字应变为“N”，字母应变为“L”，其他字符应保持不变。

例如如果 A1 包含“A35p@5”，则 B1 中的输出应为“LNNL@N”。

到目前为止，这是我的代码，但它只适用于第一个字符。同样对于其他或特殊字符，输出只是继续复制字符之后的任何内容。在下面的 Excel 和 VBA 代码中查看我的测试用例的输出。我在这里错过了什么？

Sub myMacro()

    'Define variables
    Dim char As String

    For I = 1 To Range("A10").End(xlUp).Row
        For J = 1 To Len(Range("A" & I))
            
            char = Left(Range("A" & I), J)
            
            If IsNumeric(char) Then
                Range("B" & I).Value = "N"
            ElseIf IsLetter(char) Then
                Range("B" & I).Value = "L"
            ElseIf IsSecialCharacter(char) Then
                Range("B" & I).Value = char
            End If
            
        Next J
    Next I
End Sub

Function IsLetter(r As String) As Boolean
    If r = "" Then Exit Function
    Dim x As Long
    x = Asc(UCase(r))
    IsLetter = (x > 64 And x < 91)
End Function

Function IsSecialCharacter(r As String) As Boolean
    If r = "" Then Exit Function
    Dim x As Long
    x = Asc(UCase(r))
    IsSecialCharacter = (x > 31 And x < 48) Or (x > 57 And x < 65) Or (x > 90 And x < 97) Or (x > 122 And x < 127)
End Function

Answer 1

很好的问题和查询。我花了一些时间给你几个选择：

---

1) Microsoft 365 动态数组功能：

如果你有 Microsoft365，你可以使用：

B1中的公式：

=IFERROR(LET(X,MID(A1,SEQUENCE(LEN(A1)),1),CONCAT(IF(ISNUMBER(X*1),"N",IF(ISNUMBER(FIND(UPPER(X),"ABCDEFGHIJKLMNOPQRSTUVWXYZ")),"L",X)))),"")

---

2) Excel VBA - Like() 运算符：

这是一个 VBA 例程，它将循环每个字符串中的每个字符并通过 Like() 运算符进行比较：

Sub Test()

Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Dim lrow As Long, x As Long, i As Long, arr As Variant
Dim char As String, tmp As String, full As String

lrow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
arr = ws.Range("A1:B" & lrow).Value
For x = LBound(arr) To UBound(arr)
    If Len(arr(x, 1)) > 0 Then
        full = ""
        For i = 1 To Len(arr(x, 1))
            char = Mid(arr(x, 1), i, 1)
            If char Like "[!A-Za-z0-9]" Then
                tmp = char
            ElseIf char Like "#" Then
                tmp = "N"
            Else
                tmp = "L"
            End If
            full = full & tmp
        Next
        arr(x, 2) = full
    End If
Next
ws.Range("A1:B" & lrow).Value = arr

End Sub

---

3) Excel VBA - Regexp 对象：

虽然Like() 运算符看起来像一个正则表达式，但它并不完全相同。然而，我们也可以使用“RegeXp”对象：

Sub Test()

Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Dim lrow As Long, x As Long, arr As Variant

lrow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
arr = ws.Range("A1:B" & lrow).Value

With CreateObject("VBScript.RegExp")
    .Global = True
    For x = LBound(arr) To UBound(arr)
        .Pattern = "[a-zA-Z]"
        arr(x, 2) = .Replace(arr(x, 1), "L")
        .Pattern = "\d"
        arr(x, 2) = .Replace(arr(x, 2), "N")
    Next
End With

ws.Range("A1:B" & lrow).Value = arr

End Sub

Answer 2

让我们创建一个函数来将文本转换为新格式，并使用一个 Sub 来运行循环。然后，让我们从字母中去除变音符号，并使用 Switch 语句来检查字符是数字、字母还是其他：（注意，如果字符既不是数字也不是字母，我们不需要运行额外的检查来看看它是否是“其他任何东西”——因为，剩下的就是这些了！）

Sub MyMacro()
    Dim rTMP As Range
    For Each rTMP In Range(Cells(1,1), Cells(Rows.Count,1).End(xlUp)).Cells
        rTMP.Offset(0,1).Value = TextToMask(rTmp.Value)
    Next rTMP
End Sub

Function TextToMask(Value As String) As String
    Const NumberValue AS String = "N"
    Const LetterValue AS String = "L"
    Const SymbolValue AS String = ""
    Dim i AS Long, CleanValue As String
    CleanValue = StripDiacritics(Value)

    If Len(Value)<1 Then Exit Function

    For i = 1 To Len(Value)
        Select Case Mid(CleanValue, i, 1)
            Case "0" To "9"
                TextToMask = TextToMask & Left(NumberValue & Mid(Value, i), 1)
            Case "A" To "Z", "a" To "z"
                TextToMask = TextToMask & Left(LetterValue & Mid(Value, i), 1)
            Case Else
                TextToMask = TextToMask & Left(SymbolValue & Mid(Value, i), 1)
        End Select
    Next i
End Function

Function StripDiacritics(Value As String) As Value
    'This will convert letters like "á" to "a", etc
    If Len(Value) < 1 Then Exit Function
    Dim i AS Long, Letters As Variant, Comparison As Variant
    Letters = Array("a","b","c","d","e","f","g","h","i","j","k","l","m", _
                    "n","o","p","q","r","s","t","u","v","w","x","y","z")
    
    For i = 1 To Len(Value)
        Comparison = Application.Match(Mid(Value, i, 1), Letters)
        
        If IsError(Comparison) Then
            StripDiacritics = StripDiacritics & Mid(Value, i, 1)
        Else
            StripDiacritics = StripDiacritics & Chr(Comparison - 1 + 
                IIF(Mid(Value, i, 1)=UCase(Mid(Value, i, 1)), Asc("A"), Asc("a")))
        End If
    Next i
End Function

Answer 3

我强烈建议您为 VBA 安装免费且出色的 RubberDuck 插件。

通常，在 Excel 的宏中，您应该尽量减少对 excel 对象的引用。即将数据带入 VBA，在 VBA 中对其进行操作，然后将结果放回 Excel。对于少数引用，这可能不是什么大问题，但随着输入范围的增加，对 Excel 对象的访问速度会变得很慢。

您的代码可以通过一些小改动大大简化。通过为变量赋予更有意义的名称也可以使其更具可读性

请研究下面的代码，看看我上面的意思。

Option Explicit

Public Const Letters                As String = "abcdefghijklmnopqrstuvwxyz"
Public Const Numbers                As String = "0123456789"
Public Const FoundLetter            As String = "L"
Public Const FoundNumber            As String = "N"

Public Sub Test()

    GenerateCharacterTemplates ActiveSheet
    
End Sub


Public Sub GenerateCharacterTemplates(ByVal ipSheet As Worksheet)

    Dim myRowIndex As Long
    For myRowIndex = 1 To ipSheet.Range("A10").End(xlUp).Row
    
        Dim myString As String
        ' Ensure that numbers can be processed as strings
        myString = LCase$(CStr(ipSheet.Range("A" & myRowIndex).Value))
        
        Dim myStringIndex As Long
        Dim myResult As String
        myResult = vbNullString
        For myStringIndex = 1 To Len(myString)

            Dim myChar As String
            myChar = Mid$(myString, myStringIndex, 1)

            Dim myClassification As String
            
            If IsNumber(myChar) Then
            
                myClassification = FoundNumber
                
                
            ElseIf IsLetter(myChar) Then
            
                myClassification = FoundLetter
                
                
           Else
           
                myClassification = myChar
                
                
            End If
            
            myResult = myResult & myClassification
            

        Next myStringIndex
        
        ipSheet.Range("B" & CStr(myRowIndex)).Value = myResult
        
        
    Next myRowIndex
    
End Sub

Public Function IsLetter(ByVal ipChar As String) As Boolean

    If ipChar = vbNullString Then Exit Function
    IsLetter = InStr(Letters, ipChar) > 0
    
End Function

Public Function IsNumber(ByVal ipChar As String) As Boolean

    If ipChar = vbNullString Then Exit Function
    IsNumber = InStr(Numbers, ipChar) > 0
    
End Function

上面的代码产生以下内容

1C31    NLNN
C223    LNNN
34D     NNL
G4h/    LNh/
145     NNN
    
V       L
8       N
)K      )L

Answer 4

更新现有代码

您应该使用MID 而不是LEFT。

Option Explicit

Sub myMacro()

'Define variables
Dim char As String
Dim I As Long
Dim J As Long

    For I = 1 To Range("A10").End(xlUp).Row
        For J = 1 To Len(Range("A" & I))

            char = Mid(Range("A" & I), J, 1)

            If IsNumeric(char) Then
                Range("B" & I).Value = Range("B" & I).Value & "N"
            ElseIf IsLetter(char) Then
                Range("B" & I).Value = Range("B" & I).Value & "A"
            ElseIf IsSpecialCharacter(char) Then
                Range("B" & I).Value = Range("B" & I).Value & char
            End If

        Next J
    Next I
End Sub

Function IsLetter(r As String) As Boolean
    If r = "" Then Exit Function
    Dim x As Long
    x = Asc(UCase(r))
    IsLetter = (x > 64 And x < 91)
End Function

Function IsSpecialCharacter(r As String) As Boolean
    If r = "" Then Exit Function
    Dim x As Long
    x = Asc(UCase(r))
    IsSpecialCharacter = (x > 31 And x < 48) Or (x > 57 And x < 65) Or (x > 90 And x < 97) Or (x > 122 And x < 127)
End Function

用户定义函数

这是您可以使用的 UDF。

Function Codify(strVal As String) As String
Dim ch As String
Dim I As Long

    If strVal = "" Then Exit Function

    For I = 1 To Len(strVal)
        ch = Mid(strVal, I, 1)

        If IsNumeric(ch) Then
            Codify = Codify & "N"
        ElseIf IsLetter(ch) Then
            Codify = Codify & "A"
        ElseIf IsSpecialCharacter(ch) Then
            Codify = Codify & ch
        End If
    Next I

End Function