Sub TEST()
Dim Arr, xD, i&, j&, A$, B, T$, N&
[E2:F2000].ClearContents
Arr = Range([B6], [A65536].End(xlUp))
Set xD = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(Arr)
A = Arr(i, 1): B = Arr(i, 2)
If A = "" Or Val(B) = 0 Then GoTo 101
If xD(A) = 0 Then N = N + 1: xD(A) = N: Arr(N, 1) = A: Arr(N, 2) = 0
B = Split(B & "-" & B, "-")
For j = B(0) To B(1)
T = A & "/" & j: xD(T) = xD(T) + 1
If xD(T) = 1 Then Arr(xD(A), 2) = Arr(xD(A), 2) + 1
Next j
101: Next
If N > 0 Then [E2:F2].Resize(N) = Arr
End Sub作者: jesscc 時間: 2019-8-4 16:22
以下程式碼放在一般模組:
Function GetCount(xA As Range, xB As Range, C$)
Dim Arr, Brr, xD, i&, j&, B
Set xD = CreateObject("Scripting.Dictionary")
Arr = xA: Brr = xB
For i = 1 To UBound(Arr)
If Arr(i, 1) <> C Or Val(Brr(i, 1)) = 0 Then GoTo 101
B = Split(Brr(i, 1) & "-" & Brr(i, 1), "-")
For j = B(0) To B(1): xD(j) = 1: Next j
101: Next
GetCount = xD.Count
End Function
Option Explicit
Sub TEST_1()
Dim Brr, Crr, Y, R&, i&, j%, N&, T1$, T2$, V1&, V2&
Set Y = CreateObject("Scripting.Dictionary")
[E2:F2000].ClearContents
Brr = Range([B7], Cells(Rows.Count, 1).End(3))
ReDim Crr(1 To UBound(Brr), 1 To 2)
For i = 1 To UBound(Brr)
T1 = Brr(i, 1): T2 = Brr(i, 2)
If T1 = "" Or Val(T2) = 0 Then GoTo i01
V1 = Val(T2): V2 = StrReverse(Split(StrReverse(T2), "-")(0))
For j = V1 To V2
If Y(T1) = "" Then N = N + 1: Y(T1) = N: Crr(N, 1) = T1
If Y(T1 & j) = "" Then
R = Y(T1): Y(T1 & j) = 1: Crr(R, 2) = Crr(R, 2) + 1
End If
Next
i01: Next
If N > 0 Then [E2].Resize(N, 2) = Crr
Set Y = Nothing: Erase Brr, Crr
End Sub
