Question

用VBA实现EXCEL公式的这个功能，谢谢！具体如图所示！求具体方法！谢谢！

求具体方法！谢谢！

Answer 1

测试了下运行效率，10000个数据大概2秒左右，不知能否满足你的要求。

Sub TextCompare()
    Dim CpString As String
    Dim OriRang As Range
    Dim cell As Range
    Dim I As Integer
    
    CpString = Range("B1").Value
    Set OriRang = Range("A1:A10000")
    For Each cell In OriRang
        cell.Offset(0, 2) = "√"
        For I = 1 To Len(CpString)
            If InStr(1, cell, Mid(CpString, I, 1)) > 0 Then
                cell.Offset(0, 2) = "ⅹ"
                Exit For
            End If
        Next
        Set cell = cell.Offset(1, 0)
    Next
End Sub

追问

老师我待会试一下 如果有问题 再麻烦你 好吗？

追答

可以的

追问

谢谢老师

再请教你个问题就是如图所示

追答

等会

追问

好的 谢谢 老师

追答

Sub Interval()
    Dim OriRng As Range
    Dim cell As Range
    Dim Firstaddress As String
    
    With ActiveSheet.Columns("C:C").SpecialCells(xlCellTypeConstants, 23)
        Set cell = .Find(what:="√", lookat:=xlWhole)
        On Error GoTo 0
        If Not cell Is Nothing Then
            Firstaddress = cell.Address
            Do
                cell.Offset(0, 1) = cell.Row - .FindPrevious(cell).Row
                Set cell = .FindNext(cell)
            Loop While Not cell Is Nothing And cell.Address <> Firstaddress
        End If
    End With
End Sub

追问

老师，你的解答非常准确，太感谢你了！以后有什么不清楚的直接私信给你，可以吗？

Answer 2

用公式能解决的，不必VBA吧

追问

量大 公式太卡了
帮帮忙帮我弄一下

Answer 3

For i = 1 To Len([b1])
Set c = [a:a].Find(Mid([b1], i, 1), , , xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Range("c" & c.Row) = "√"
Set c = [a:a].FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
Next
temp = Range("c1:c" & [a1].End(xlDown).Row).Replace("", "×")