|
- Sub 模糊多条件汇总()
- Dim arr, brr, d As Object, d2 As Object, r%, i&, x%, m&, y&, s$
- Dim k As Variant
- Set d = CreateObject("scripting.dictionary")
- Set d2 = CreateObject("scripting.dictionary")
- Application.ScreenUpdating = False
- 生成不重复值姓名
- r = Range("a65536").End(3).Row
- arr = Range("a5:d" & r)
- With Sheet1
- r = .Range("a65536").End(3).Row
- brr = .Range("a4:m" & r)
- End With
- For i = 1 To UBound(brr)
- d(brr(i, 1)) = ""
- Next
- For i = 1 To UBound(arr) '姓名
- s = arr(i, 1)
- For Each k In d.keys '月份
- For x = 1 To UBound(brr)
- If InStr(brr(x, 3), s) Then
- If brr(x, 1) = 1 * k And brr(x, 9) <> "包装" Then
- m = m + 1
- End If
- End If
- Next
- If m > 2 Then
- y = y + 1
- m = 0
- End If
- Next
- arr(i, 2) = y
- m = 0
- y = 0
- For x = 1 To UBound(brr)
- If InStr(brr(x, 3), s) And brr(x, 13) = "NPI" Then
- d2(brr(x, 7)) = d2(brr(x, 7)) & brr(i, 8) & ","
- End If
- Next
- arr(i, 3) = d2.Count
- d2.RemoveAll
- Next
- [a5].Resize(UBound(arr), 3) = arr
- Set d = Nothing
- Set d2 = Nothing
- Application.ScreenUpdating = True
- End Sub
- Sub 生成不重复值姓名()
- Dim arr, trr, brr(), sa, d, s$, t$, r&, i&, x&, n&
- Set d = CreateObject("scripting.dictionary")
- With Sheet1
- r = .Range("a65536").End(3).Row
- arr = .Range("a4:m" & r)
- End With
- ReDim trr(1 To 500, 1 To 1)
- For i = 1 To UBound(arr)
- s = arr(i, 3)
- If s <> "" Then
- If InStr(s, "/") Then
- sa = Split(s, "/")
- For x = 0 To UBound(sa)
- n = n + 1
- trr(n, 1) = sa(x)
- Next
- Else
- n = n + 1
- trr(n, 1) = s
- End If
- End If
- Next
- ReDim brr(1 To UBound(trr), 1 To 1)
- For i = 1 To UBound(trr)
- t = Trim(CStr(trr(i, 1)))
- If t <> "" And Not d.exists(t) Then
- d(t) = ""
- brr(d.Count, 1) = t
- End If
- Next i
- If d.Count > 0 Then [a5].Resize(d.Count, 1) = brr
- Set d = Nothing
- End Sub
复制代码 |
|