准提部林

Sub TEST()
Dim A, xD, T$(1), N&(1)
Set xD = CreateObject("Scripting.Dictionary")
T(0) = Mid([工作表2!b3], 1, 1)
T(1) = Mid([工作表2!b3], 2, 1)
For Each A In Range([工作表1!c2], [工作表1!c1].Cells(Rows.Count, 1).End(xlUp)).Value
　　If A = "" Or xD(A) = 1 Then GoTo 101
　　If InStr(A, T(0)) Then
　　　　If InStr(A, T(1)) Then N(1) = N(1) + 1 Else N(0) = N(0) + 1
　　End If
　　xD(A) = 1
101: Next
[工作表2!A5] = N(0)
[工作表2!A6] = N(1)
End Sub

准提部林

回復 8# starry1314


請提出範例, 並模擬結果及說明規則~~

准提部林

回復 11# starry1314


Sub TEST()
Dim A, xD, Arr, Brr, j&, Jm&, k%
Set xD = CreateObject("Scripting.Dictionary")
Arr = [工作表2!A3:N3]
ReDim Brr(1 To 2, 1 To UBound(Arr, 2))
For Each A In Range([工作表1!c2], [工作表1!c1].Cells(Rows.Count, 1).End(xlUp)).Value
　　If A = "" Or xD(A) = 1 Then GoTo 101
　　Jm = 1
　　For j = 3 To UBound(Arr, 2) Step 2
　　　　If InStr(A, Arr(1, j)) Then Jm = j: Exit For
　　Next j
　　If InStr(A, "V") Then k = 2 Else k = 1
　　Brr(k, Jm) = Brr(k, Jm) + 1
　　xD(A) = 1
101: Next
[工作表2!A5:N6] = Brr
End Sub

准提部林

回復 13# starry1314


那是累計不重覆個數!
沒資料顯示1? 什麼意思?改成以下:讓資料範圍多加二列空白列
For Each A In Range([工作表1!c2], [工作表1!c1].Cells(Rows.Count, 1).End(xlUp)(3)).Value