|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
- Private Sub CommandButton1_Click()
- Dim d As Object
- Dim aArr, bArr, cArr(), tgStr, tArr(1 To 2), xArr
- Set d = CreateObject("scripting.dictionary")
- aArr = Sheet2.UsedRange
- tgStr = Sheet3.[c2]
- Intersect(Sheet3.Rows("8:" & Sheet3.UsedRange.Rows.Count), Sheet3.Columns("c:Y")).ClearContents
- For i = 2 To UBound(aArr, 1)
- If aArr(i, 3) = tgStr Then
- d(aArr(i, 2) & "," & aArr(i, 4)) = d(aArr(i, 2) & "," & aArr(i, 4)) + 1
- End If
- Next
- tArr(1) = d.keys
- tArr(2) = d.items
- bArr = WorksheetFunction.Transpose(tArr)
- d.RemoveAll
- For i = 1 To UBound(bArr, 1)
- d(Split(bArr(i, 1), ",")(0)) = d(Split(bArr(i, 1), ",")(0))
- Next
- ReDim cArr(1 To UBound(bArr, 1), 1 To 3)
- For i = 1 To UBound(cArr, 1)
- cArr(i, 1) = Split(bArr(i, 1), ",")(0)
- cArr(i, 2) = Split(bArr(i, 1), ",")(1)
- cArr(i, 3) = bArr(i, 2)
- Next
- tArr(1) = d.keys
- Erase aArr
- aArr = WorksheetFunction.Transpose(Sheet3.[c7:y7])
- ReDim Preserve aArr(1 To 23, 1 To d.Count + 1)
- For i = 2 To UBound(aArr, 2)
- aArr(1, i) = tArr(1)(i - 2)
- Next
- aArr = WorksheetFunction.Transpose(aArr)
- For i = 2 To UBound(aArr, 1)
- For j = 1 To UBound(cArr, 1)
- If aArr(i, 1) = cArr(j, 1) Then
- For k = 2 To UBound(aArr, 2) - 2
- If aArr(1, k) = cArr(j, 2) Then
- aArr(i, k) = cArr(j, 3)
- n = n + 1
- If aArr(i, k) >= 2 Then m = m + 1
- End If
- Next k
- End If
- Next j
- aArr(i, 22) = n / 20
- aArr(i, 23) = m / n
- n = 0
- m = 0
- Next i
- Sheet3.[c7].Resize(UBound(aArr, 1), UBound(aArr, 2)) = aArr
- Sheet3.[c7].CurrentRegion.Sort [c7], xlAscending, Header:=xlYes
- End Sub
复制代码
试一下还可以 |
|