循环VBA中的调用功能

Question

My problem is simple for VBA pro. if you can help me to understand please. I am trying to call a function which keep only caps in a cell and past the result in the next column by looping all the rows. Please take a look at the code below. Thank you.

Option Explicit
Sub LLOP()
Dim i As Integer
i = 1
Do While Cells(i, 10).Value <> ""
Cells(i, 11).Value = Cells(i, 10).Value = ExtractCap
i = i + 1
Loop

End Sub


Option Explicit

Function ExtractCap(Txt As String) As String

Application.Volatile
Dim xRegEx As Object
Set xRegEx = CreateObject("VBSCRIPT.REGEXP")
xRegEx.Pattern = "[^A-Z]"
xRegEx.Global = True
ExtractCap = xRegEx.Replace(Txt, "")
Set xRegEx = Nothing

End Function

Answer 1

Try something like as follows. Notes to follow.

1) Extract cap requires an argument which is the string you want to replace. I have used the value in the adjacent column

2) Option Explicit should only occur once at the top of the module

3) As you are looping rows uses Long not Integer to avoid potential overflow

4) Comparison with vbNullString is faster than empty string literal ""

Edit:

5) See @Jeeped's comment re Static xRegEx As Object followed by if xregex is nothing then Set xRegEx = CreateObject("VBSCRIPT.REGEXP") which significantly improves performance when called in a loop as the regex object only gets created once

Option Explicit
Sub LLOP()

    Dim i As Long
    i = 1

    With ThisWorkbook.Worksheets("Sheet1") 'change as appropriate

    Do While .Cells(i, 10).Value <> vbNullString 'column J
        .Cells(i, 11).Value = ExtractCap(.Cells(i, 10).Text) 'column K
        i = i + 1
    Loop

    End With

End Sub


Public Function ExtractCap(Txt As String) As String

    Application.Volatile
    Dim xRegEx As Object
    Set xRegEx = CreateObject("VBSCRIPT.REGEXP")
    xRegEx.Pattern = "[^A-Z]"
    xRegEx.Global = True
    ExtractCap = xRegEx.Replace(Txt, vbNullString)

End Function

Answer 2

Assuming that you want to enter a custom =ExtractCap() formula in the 11. column, with a parameter of the 10. column, this is a possible solution:

Option Explicit

Sub LLOP()

    Dim i As Long: i = 1
    Do While Cells(i, 10).Value <> ""
        Cells(i, 11).Formula = "=ExtractCap(""" & Cells(i, 10) & """)"
        i = i + 1
    Loop
End Sub

Function ExtractCap(Txt As String) As String

    Application.Volatile
    Static xRegEx As Object
    If xRegEx Is Nothing Then Set xRegEx = CreateObject("VBSCRIPT.REGEXP")
    xRegEx.Pattern = "[^A-Z]"
    xRegEx.Global = True
    ExtractCap = xRegEx.Replace(Txt, "")

End Function

---

The .Formula passes the function ExtractCap as a formula with its parameter of Cells(i, 10) .

Answer 3

Try below alternative code. Your method is complicated and uses regular expressions (which is nice, but in your case, ineffective).

The code:

Option Explicit
Sub LLOP()
Dim i As Integer
i = 1

'indentation! in your original code, you didn't have proper indentation
'I know that VBA editor don't indent code automatically, but it's worth the effort
Do While Cells(i, 10).Value <> ""
    ' invalid syntax!
    ' first, this is kind of multiple assignment (I don't know what are you trying to do)
    ' secondly, you call your function without arguments
    ' Cells(i, 11).Value = Cells(i, 10).Value = ExtractCap
    ' I guess you wanted something like this
    Cells(i, 11).Value = ExtractCap(Cells(i, 10).Value)
    'or using my function:
    Cells(i, 11).Value = SimpleExtractCap(Cells(i, 10).Value)
    i = i + 1
Loop

End Sub

'THIS IS YOUR FUNCTION, which is complicated (unnecessarily)
Function ExtractCap(Txt As String) As String

Application.Volatile
Dim xRegEx As Object
Set xRegEx = CreateObject("VBSCRIPT.REGEXP")
xRegEx.Pattern = "[^A-Z]"
xRegEx.Global = True
ExtractCap = xRegEx.Replace(Txt, "")
Set xRegEx = Nothing

End Function

'this is my alternative to your function, which is very simple and basic
Function SimpleExtractCap(Txt As String) As String
SimpleExtractCap = ""
Dim i As Long, char As String
For i = 1 To Len(Txt)
    char = Mid(Txt, i, 1)
    'if we have upper-case letter, then append it to the result
    If isLetter(char) And char = UCase(char) Then
        SimpleExtractCap = SimpleExtractCap & char
    End If
Next
End Function

Edit:

In order to check if given character is letter, you'll need additional function:

Function isLetter(letter As String) As Boolean
Dim upper As String
upper = UCase(letter)
isletter = Asc(upper) > 64 And Asc(upper) < 91
End Function

Now, I added this function to code, to check if character is letter.