String 使用VBA对字符串中的字符串进行计数

我有产品代码：（它们在活动表的C列中）

我有一个大的数据列表：（它们在“Sheet1”的C列中）

我想计算产品代码在数据列表中出现了多少次。所以这种情况的结果是：（结果是活动表的H列）

我已使用此代码完成此操作：

Sub CountcodesPLC()
    Dim i, j As Integer, icount As Integer
    Dim ldata, lcodes As Long

    icount = 0

    lcodes = Cells(Rows.Count, 3).End(xlUp).Row
    ldata = Worksheets("Sheet1").Cells(Rows.Count, 3).End(xlUp).Row

    For i = 10 To lcodes
        For j = 2 To ldata
            If InStr(Worksheets("Sheet1").Range("C" & j), Range("C" & i)) <> 0 Then
                icount = icount + 1
            End If
        Next j

        If icount <> 0 Then
            Range("H" & i).Value = icount
        End If

       icount = 0
    Next i
End Sub

另外，我将有大约1000个产品代码和大约60000个数据字符串。

---

我的代码会崩溃吗

您的代码似乎还可以。但如果您只想匹配字符串的第一部分（a'ka StartsWith），我只会更改这一行：

If InStr(Worksheets("Sheet1").Range("C" & j), Range("C" & i)) <> 0 Then

有关更多详细信息，请参阅：

使用词汇表

Dim Dict As Scripting.Dictionary
Set Dict = New Scripting.Dictionary

Arr = Split("refer your text here", "_")

For I = LBound(Arr) To UBound(Arr)
    If Dict.Exists(Arr(I)) Then
        Dict(Arr(I)) = Dict(Arr(I)) + 1 'increment
    Else
        Dict.Add Arr(I), 1
    End If
Next I

---

这可能是OTT的要求，但应该工作得很快

Public Sub Sample()
Dim WkSht       As Worksheet
Dim LngRow      As Long
Dim AryLookup() As String
Dim VntItem     As Variant

'We put what we want to search into an array, this makes it a lot quicker to search
Set WkSht = ThisWorkbook.Worksheets("Sheet1")
    ReDim AryLookup(0)
    LngRow = 1
    Do Until WkSht.Range("A" & LngRow) = ""
        If AryLookup(UBound(AryLookup, 1)) <> "" Then ReDim Preserve AryLookup(UBound(AryLookup, 1) + 1)
        AryLookup(UBound(AryLookup, 1)) = Trim(UCase(WkSht.Range("A" & LngRow)))
        LngRow = LngRow + 1
    Loop
Set WkSht = Nothing

'Then we go down the list and check the array against each item
Set WkSht = ActiveSheet
    LngRow = 1
    Do Until WkSht.Range("A" & LngRow) = ""
        WkSht.Range("B" & LngRow) = 0
        For Each VntItem In AryLookup()

            'This looks for the match without any of the exclusion items
            If (InStr(1, VntItem, Trim(UCase(WkSht.Range("A" & LngRow)))) <> 0) And _
                (InStr(1, VntItem, "NP") = 0) And _
                (InStr(1, VntItem, "ISK") = 0) Then
                WkSht.Range("B" & LngRow) = WkSht.Range("B" & LngRow) + 1
            End If
        Next
        LngRow = LngRow + 1
    Loop
Set WkSht = Nothing

MsgBox "Done"

End Sub

Public子示例（）
将WkSht设置为工作表
长得一样长
字符串形式的查找（）
变异体
“我们将要搜索的内容放入一个数组中，这使搜索速度大大加快
设置WkSht=ThisWorkbook.Worksheets（“Sheet1”）
重读查找（0）
LngRow=1
直到WkSht.Range（“A”和LngRow）=
如果AryLookup（UBound（AryLookup，1））“”则ReDim保留AryLookup（UBound（AryLookup，1）+1）
AryLookup（UBound（AryLookup，1））=修剪（UCase（WkSht.Range（“A”）和LngRow）））
LngRow=LngRow+1
环
设置WkSht=Nothing
'然后，我们沿着列表，检查每个项目的数组
设置WkSht=ActiveSheet
LngRow=1
直到WkSht.Range（“A”和LngRow）=
WkSht.范围（“B”和LngRow）=0
对于AryLookup（）中的每个Vnitem
'这将查找不包含任何排除项的匹配项
If（仪表（1，Vnitem，微调（UCase（WkSht.Range（“A”）和LngRow）））0）和_
（仪表（1，Vnitem，“NP”）=0）和_
（InStr（1，vnitem，“ISK”）=0）然后
WkSht.Range（“B”和LngRow）=WkSht.Range（“B”和LngRow）+1
如果结束
下一个
LngRow=LngRow+1
环
设置WkSht=Nothing
MsgBox“完成”
端接头

基本上，60000个数据字符串将进入内存中的一个数组，然后将根据1000个产品搜索该数组。在内存中搜索应该很快

我想提出的一件事是排除方法可能会产生误报

例如，排除

NP

将排除：-

NP_41533258_DO-003_14910884

NPA_41533258_DO-003_14910884

41533258\u ANP\u DO-003\u 14910884

---

您可能需要全面考虑该方法。

您是否考虑过数组公式，不确定它将如何执行vs代码，但是，您可以沿着这些线做一些事情，其中列表在A中，产品编号在B中

=总和（如果（不是（ISER（搜索（B1&““，$A$1:$A$5,1）））*（ISER（搜索（“NP_“，$A$1:$A$5,1））），1,0））

---

如果“NP”将被包含排除项的范围替换，我将作为NP留下来显示发生了什么。

代码如下所示。但我不知道速度

Sub test()
    Dim vDB, vLook, vSum(), Sum As Long
    Dim Ws As Worksheet, dbWs As Worksheet
    Dim s As String, sF As String, sCode As String
    Dim i As Long, j As Long, n As Long

    Set dbWs = Sheets("Sheet1")
    Set Ws = ActiveSheet

    With Ws
        vLook = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
    End With
    With dbWs
        vDB = .Range("c1", .Range("c" & Rows.Count).End(xlUp))
    End With

    n = UBound(vLook, 1)

    ReDim vSum(1 To n, 1 To 1)
    For i = 1 To n
        sF = Split(vLook(i, 1), "-")(0)
        sCode = Replace(vLook(i, 1), sF, "")
        Sum = 0
        For j = 1 To UBound(vDB, 1)
            s = vDB(j, 1)
            If Left(s, Len(sF)) = sF Or InStr(s, "NP") Or InStr(s, "ISK") Then
            Else
                If InStr(s, sCode) Then
                    Sum = Sum + 1
                End If
            End If
        Next j
        If Sum > 0 Then
            vSum(i, 1) = Sum
        End If
    Next i
    Ws.Range("h1").Resize(n) = vSum

End Sub

---

“我的代码会崩溃吗？”：真的吗？这是六万四千美元的问题吗？为什么不备份文件并运行代码，看看会发生什么？我只想说：代码审查问题在这里是离题的。您需要针对代码的问题提出特定的问题（请参阅）。旁注：（1）如果您声明

Dim ldata，lcodes为Long

，则只有最后一个变量的类型为

Long

，第一个变量仍然是

Variant

。您需要为每个变量指定一种类型，如

Dim ldata As Long，lcodes As Long

。（2） 除非与旧API通信，否则切勿使用

Integer

。请始终使用

Long

，尤其是行计数，因为Excel的行数超过了

Integer

所能处理的行数。阅读一些关于整型和长型的背景知识。谢谢，这对我很有用。是的，我知道NP，NPA的事。这个版本没问题。我将尝试编辑它，因此如果代码是字符串的第一部分，则不计算它们。如果计数为零，则保留为空。此外，当我尝试添加更多关键字（如“NP”）时，它仍然会计数。您需要在NP行

（InStr（1，vnitem，“NewValue”）=0）和

之后的

if

语句中添加一行。

If InStr(Worksheets("Sheet1").Range("C" & j), Range("C" & i)) <> 0 Then

If Worksheets("Sheet1").Range("C" & j) Like Range("C" & i) & "*" Then

Dim Dict As Scripting.Dictionary
Set Dict = New Scripting.Dictionary

Arr = Split("refer your text here", "_")

For I = LBound(Arr) To UBound(Arr)
    If Dict.Exists(Arr(I)) Then
        Dict(Arr(I)) = Dict(Arr(I)) + 1 'increment
    Else
        Dict.Add Arr(I), 1
    End If
Next I

Public Sub Sample()
Dim WkSht       As Worksheet
Dim LngRow      As Long
Dim AryLookup() As String
Dim VntItem     As Variant

'We put what we want to search into an array, this makes it a lot quicker to search
Set WkSht = ThisWorkbook.Worksheets("Sheet1")
    ReDim AryLookup(0)
    LngRow = 1
    Do Until WkSht.Range("A" & LngRow) = ""
        If AryLookup(UBound(AryLookup, 1)) <> "" Then ReDim Preserve AryLookup(UBound(AryLookup, 1) + 1)
        AryLookup(UBound(AryLookup, 1)) = Trim(UCase(WkSht.Range("A" & LngRow)))
        LngRow = LngRow + 1
    Loop
Set WkSht = Nothing

'Then we go down the list and check the array against each item
Set WkSht = ActiveSheet
    LngRow = 1
    Do Until WkSht.Range("A" & LngRow) = ""
        WkSht.Range("B" & LngRow) = 0
        For Each VntItem In AryLookup()

            'This looks for the match without any of the exclusion items
            If (InStr(1, VntItem, Trim(UCase(WkSht.Range("A" & LngRow)))) <> 0) And _
                (InStr(1, VntItem, "NP") = 0) And _
                (InStr(1, VntItem, "ISK") = 0) Then
                WkSht.Range("B" & LngRow) = WkSht.Range("B" & LngRow) + 1
            End If
        Next
        LngRow = LngRow + 1
    Loop
Set WkSht = Nothing

MsgBox "Done"

End Sub

Sub test()
    Dim vDB, vLook, vSum(), Sum As Long
    Dim Ws As Worksheet, dbWs As Worksheet
    Dim s As String, sF As String, sCode As String
    Dim i As Long, j As Long, n As Long

    Set dbWs = Sheets("Sheet1")
    Set Ws = ActiveSheet

    With Ws
        vLook = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
    End With
    With dbWs
        vDB = .Range("c1", .Range("c" & Rows.Count).End(xlUp))
    End With

    n = UBound(vLook, 1)

    ReDim vSum(1 To n, 1 To 1)
    For i = 1 To n
        sF = Split(vLook(i, 1), "-")(0)
        sCode = Replace(vLook(i, 1), sF, "")
        Sum = 0
        For j = 1 To UBound(vDB, 1)
            s = vDB(j, 1)
            If Left(s, Len(sF)) = sF Or InStr(s, "NP") Or InStr(s, "ISK") Then
            Else
                If InStr(s, sCode) Then
                    Sum = Sum + 1
                End If
            End If
        Next j
        If Sum > 0 Then
            vSum(i, 1) = Sum
        End If
    Next i
    Ws.Range("h1").Resize(n) = vSum

End Sub