Option Explicit
Sub 求不重复值1()
Dim d As Object, arr, i%, a
Set d = CreateObject("scripting.dictionary")
d.comparemode = 0
arr = Sheet2.Range("a1:a12")
For i = LBound(arr) To UBound(arr)
d(arr(i, 1)) = ""
Next
a = d.keys
[c2].Resize(d.Count) = WorksheetFunction.Transpose(a)
End Sub
Sub 求不重复值2()
Dim d As Object, arr, i%, a
Set d = CreateObject("scripting.dictionary")
d.comparemode = 1
arr = Sheet2.Range("a1:a12")
For i = LBound(arr) To UBound(arr)
d(arr(i, 1)) = ""
Next
a = d.keys
[d2].Resize(d.Count) = WorksheetFunction.Transpose(a)
End Sub
Sub 双向求值()
Dim d As Object, arr, i%, a
Set d = CreateObject("scripting.dictionary")
d.comparemode = 0
arr = Sheet9.Range("a1:b6")
For i = LBound(arr) To UBound(arr)
d(arr(i, 1)) = arr(i, 2)
d(arr(i, 2)) = arr(i, 1)
Next
[e3] = d([d3].Value)
MsgBox "d3对应的值为" & [e3].Value
End Sub
Sub 多条件查找()
Dim d As Object, arr, i%, a, b, c
Set d = CreateObject("scripting.dictionary")
d.comparemode = 0
arr = Sheet8.Range("a2:d5")
For i = LBound(arr) To UBound(arr)
If d.exists(arr(i, 1)) = 0 Then
d(arr(i, 1) & "|" & arr(i, 2)) = arr(i, 3) & "|" & arr(i, 4)
Else
d(arr(i, 1) & "|" & arr(i, 2)) = arr(i, 3) & "|" & arr(i, 4) + d(arr(i, 1) & "|" & arr(i, 2))
End If
Next
b = d.keys
c = d.items
ReDim a(1 To d.Count, 1 To UBound(arr))
For i = 0 To d.Count - 1
a(i + 1, 1) = WorksheetFunction.Transpose(Split(b(i), "|")(0))
a(i + 1, 2) = WorksheetFunction.Transpose(Split(b(i), "|")(1))
a(i + 1, 3) = WorksheetFunction.Transpose(Split(c(i), "|")(0))
a(i + 1, 4) = WorksheetFunction.Transpose(Split(c(i), "|")(1))
Next
[a12].Resize(d.Count, 4) = a
End Sub
Sub 单条件求和()
Dim d As Object, arr, i%, a
Set d = CreateObject("scripting.dictionary")
d.comparemode = 0
arr = Sheet10.Range("b2:c5")
For i = LBound(arr) To UBound(arr)
If d.exists(arr(i, 1)) = 0 Then
d(arr(i, 1)) = arr(i, 2)
Else
d(arr(i, 1)) = arr(i, 2) + d(arr(i, 1))
End If
Next
[e2].Resize(d.Count, 2) = WorksheetFunction.Transpose(Array(d.keys, d.items))
End Sub
Sub 多列求和()
Dim d As Object, arr, i%, a(1 To 10000, 1 To 4), K%
Set d = CreateObject("scripting.dictionary")
d.comparemode = 0
arr = Sheet12.Range("a2:d6")
For i = LBound(arr) To UBound(arr)
If d.exists(arr(i, 1)) = 0 Then
K = K + 1
d(arr(i, 1)) = K
a(K, 1) = arr(i, 1)
a(K, 2) = arr(i, 2)
a(K, 4) = arr(i, 4)
Else
a(d(arr(i, 1)), 2) = arr(i, 2) + a(d(arr(i, 1)), 2)
a(d(arr(i, 1)), 4) = arr(i, 4) + a(d(arr(i, 1)), 4)
End If
a(d(arr(i, 1)), 3) = a(d(arr(i, 1)), 4) / a(d(arr(i, 1)), 2)
Next
[a13].Resize(d.Count, 4) = a
End Sub
Sub 多条件求和()
Dim d As Object, arr, i%, a, b, c
Set d = CreateObject("scripting.dictionary")
d.comparemode = 0
arr = Sheet13.Range("a2:c6")
For i = LBound(arr) To UBound(arr)
If d.exists(arr(i, 1)) = 0 Then
d(arr(i, 1) & "|" & arr(i, 2)) = arr(i, 3)
Else
d(arr(i, 1) & "|" & arr(i, 2)) = arr(i, 3) + d(arr(i, 1) & "|" & arr(i, 2))
End If
Next
b = d.keys
c = d.items
ReDim a(1 To d.Count, 1 To UBound(arr, 2))
For i = 0 To d.Count - 1
a(i + 1, 1) = WorksheetFunction.Transpose(Split(b(i), "|")(0))
a(i + 1, 2) = WorksheetFunction.Transpose(Split(b(i), "|")(1))
a(i + 1, 3) = WorksheetFunction.Transpose(c(i))
Next
[a11].Resize(d.Count, 3) = a
End Sub
|