|
贴上源代码，欢迎测试，数据最好不要排序，越乱越好！ Option Explicit
'-----------------------
Type tsf
name As String
sum As Integer
End Type
'-----------------------
Type tgz
name As String
sum As Long
sfsum As Byte
End Type
'-----------------------
Type tjx
name As String
sum As Long
gzsum As Byte
End Type
'----------------------
Dim data(1 To 50) As tjx, data1(1 To 50, 1 To 250) As tgz, data2(1 To 50, 1 To 200, 1 To 100) As tsf
Dim over As Boolean, over1 As Boolean, over2 As Boolean
Dim sf As String, jx As String, gz As String Sub erw()
Dim a, arr, sw
Dim swt As tsf
Dim i As Long, m As Long, k As Integer, kk As Integer, jxsum As Byte, j As Byte, temp As Long
Dim list(), pp As Long, t As Long
Erase data
Erase data1
Erase data2
a = Timer
With Worksheets("数据")
i = .Range("a65536").End(xlUp).Row
arr = .Range("a2:c" & i)
End With
m = UBound(arr, 1)
ReDim list(1 To m, 1 To 11)
jxsum = 0
For i = 1 To m
over = False
sf = Trim(arr(i, 1))
jx = Trim(arr(i, 2))
gz = Trim(arr(i, 3))
For j = 1 To jxsum
If data(j).name = jx Then
over = True
data(j).sum = data(j).sum + 1
checkgz j
Exit For
End If
Next
If over = False Then
jxsum = jxsum + 1
data(jxsum).name = jx
data(jxsum).sum = data(jxsum).sum + 1
data(jxsum).gzsum = data(jxsum).gzsum + 1
data1(jxsum, data(jxsum).gzsum).name = gz
data1(jxsum, data(jxsum).gzsum).sum = data1(jxsum, data(jxsum).gzsum).sum + 1
data1(jxsum, data(jxsum).gzsum).sfsum = data1(jxsum, data(jxsum).gzsum).sfsum + 1
data2(jxsum, data(jxsum).gzsum, data1(jxsum, data(jxsum).gzsum).sfsum).name = sf
data2(jxsum, data(jxsum).gzsum, data1(jxsum, data(jxsum).gzsum).sfsum).sum = data2(jxsum, data(jxsum).gzsum, data1(jxsum, data(jxsum).gzsum).sfsum).sum + 1
End If
Next
pp = 0
For i = 1 To jxsum
For m = 1 To data(i).gzsum
pp = pp + 1
list(pp, 1) = m
list(pp, 2) = data(i).name
list(pp, 3) = data1(i, m).name
list(pp, 4) = data1(i, m).sum
list(pp, 5) = Round(list(pp, 4) / data(i).sum, 2)
'---------------------------------------------
For k = 1 To data1(i, m).sfsum - 1
temp = k
For kk = k + 1 To data1(i, m).sfsum
If data2(i, m, kk).sum > data2(i, m, temp).sum Then
temp = kk
End If
Next
If temp <> k Then
swt = data2(i, m, k)
data2(i, m, k) = data2(i, m, temp)
data2(i, m, temp) = swt
End If
Next
'--------------------------------------------------
If data1(i, m).sfsum > 3 Then
sw = 3
Else
sw = data1(i, m).sfsum
End If
For temp = 1 To sw
list(pp, 2 * temp + 4) = data2(i, m, temp).name
list(pp, 2 * temp + 5) = data2(i, m, temp).sum
Next
Next
pp = pp + 1
list(pp, 1) = m
list(pp, 2) = data(i).name
list(pp, 3) = "合计"
list(pp, 4) = data(i).sum
Next
Worksheets("报表").Range("L3").Resize(pp, 11) = list
' '-------------------------------------------------------------------
'
MsgBox Format(Timer - a, "0.00000000")
End Sub
Sub checkgz(n As Byte)
over1 = False
Dim i As Byte
For i = 1 To data(n).gzsum
If data1(n, i).name = gz Then
over1 = True
data1(n, i).sum = data1(n, i).sum + 1
checksf n, i
Exit For
End If
Next
If over1 = False Then
data(n).gzsum = data(n).gzsum + 1
data1(n, data(n).gzsum).name = gz
data1(n, data(n).gzsum).sum = data1(n, data(n).gzsum).sum + 1
data1(n, data(n).gzsum).sfsum = data1(n, data(n).gzsum).sfsum + 1
data2(n, data(n).gzsum, data1(n, data(n).gzsum).sfsum).name = sf
data2(n, data(n).gzsum, data1(n, data(n).gzsum).sfsum).sum = data2(n, data(n).gzsum, data1(n, data(n).gzsum).sfsum).sum + 1
End If
End Sub
Sub checksf(a As Byte, b As Byte)
over2 = False
Dim i As Byte
For i = 1 To data1(a, b).sfsum
If data2(a, b, i).name = sf Then
over2 = True
data2(a, b, i).sum = data2(a, b, i).sum + 1
Exit For
End If
Next
If over2 = False Then
data1(a, b).sfsum = data1(a, b).sfsum + 1
data2(a, b, data1(a, b).sfsum).name = sf
data2(a, b, data1(a, b).sfsum).sum = data2(a, b, data1(a, b).sfsum).sum + 1
End If
End Sub
|
楼主: 彭希仁
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2007-11-30 18:04
楼主