[讨论]有点难度的汇总

hyy514

到了好地方要留根索查

northwolves

QUOTE:

以下是引用ldy888在2007-11-27 19:57:22的发言：

呵呵 有价值的来了。现在只需要数据表里按型号排序就行了。

查看效果话随意改几个 故障名称 ：不开机2，不显示3，地区名： 广东3  ，型号：SM6123

Sub bbbb()
    Dim d2 As New Dictionary
    Dim d3 As New Dictionary
    Dim d4 As New Dictionary
    Cells.Interior.ColorIndex = Empty

   r = Sheet2.Range("a2").End(xlDown).Row - 1

    '排序可以用excel的排序,这个也不许用的话，就再套一个字典，这比绕口令还复杂的绕“脑”令，

    '有需要的人自己去绕吧

    Sheet2.Range("a2").Resize(r, 3).Sort Key1:=Sheet2.Range("B2"),Order1:=xlDescending
    
    arr = Sheet2.Range("a2").Resize(r, 3)

    For i = 1 To r
        For j = 1 To 3
            arr(i, j) = Trim(arr(i, j))    '文字净化处理
        Next
        xh = arr(i, 2)
        gz = arr(i, 3)
        d2(xh) = d2(xh) + 1
        If d3.Exists(xh) = False Then Set d3(xh) = New Dictionary
        s = d3(xh)(gz)
        xhgz = arr(i, 2) & " " & arr(i, 3)    ' 型号 故障
        If d4.Exists(xhgz) = False Then Set d4(xhgz) = New Dictionary
        d4(xhgz)(arr(i, 1)) = d4(xhgz)(arr(i, 1)) + 1
    Next
    Erase arr

    ReDim ar(1 To (d2.Count + d4.Count), 1 To 11)
    i = 0
    ii = 0
    For Each K In d4

        xh = Split(K)(0)
        gz = Split(K)(1)
        i = i + 1
        xii = d3(xh).Count
        ii = ii + 1
        ar(i, 1) = ii
        ar(i, 2) = xh
        ar(i, 3) = gz

        For Each KK In d4(K)
            ar(i, 4) = ar(i, 4) + d4(K)(KK)
            If d4(K)(KK) >= ar(i, 7) Then
                ar(i, 10) = ar(i, 8): ar(i, 11) = ar(i, 9)
                ar(i, 8) = ar(i, 6): ar(i, 9) = ar(i, 7)
                ar(i, 6) = KK: ar(i, 7) = d4(K)(KK)
            ElseIf d4(K)(KK) >= ar(i, 9) Then
                ar(i, 10) = ar(i, 8): ar(i, 11) = ar(i, 9)
                ar(i, 8) = KK: ar(i, 9) = d4(K)(KK)
            ElseIf d4(K)(KK) > ar(i, 11) Then
                ar(i, 10) = KK: ar(i, 11) = d4(K)(KK)
            End If
        Next
        ar(i, 5) = ar(i, 4) / d2(xh)

        If ar(i, 1) = d3(xh).Count Then
            i = i + 1
            ar(i, 1) = ii + 1
            ar(i, 2) = xh
            ar(i, 3) = "合计"
            ar(i, 4) = d2(xh)
            ar(i, 5) = "100%"
            ii = 0
            s = s & " " & i
        End If
    Next
    Range("a3").Resize(UBound(ar), 11) = ar
    arr = Split(s)
    For i = 1 To UBound(arr)
        Cells(arr(i) + 2, 1).Resize(1, 11).Interior.ColorIndex = 43
    Next
End Sub

 

不是一般的强. 学习ing

[em17][em17][em17][em27][em27][em27]

彭希仁

狼版,能否用ADO加数组实现一个呢?

个人感觉用ADO加数组实现此汇总会好实现一点.效率也会高很多.

kzb

QUOTE:

以下是引用彭希仁在2007-11-28 10:40:23的发言：

狼版,能否用ADO加数组实现一个呢?

个人感觉用ADO加数组实现此汇总会好实现一点.效率也会高很多.

期待狼版来一个

northwolves

有空时整一个

tycp

只用数组!

Sub hz()
Dim i As Integer, p As Integer, j As Integer, m As Integer, n As Integer
Dim s As Integer, n1 As Integer, tt As Integer
Dim over() As Boolean, over1() As Boolean, over2() As Boolean, over3() As Boolean
Dim list() As String, list1() As String, result() As String
Dim sort() As String, sort1() As String, src As String, des As String
Dim arr, temp
Dim pp As Integer, s1 As Integer
With Worksheets("数据")
p = .Range("a65536").End(xlUp).Row
arr = .Range("a2:c" & p)
End With
m = UBound(arr, 1)
ReDim over(1 To m) As Boolean
ReDim over1(1 To m) As Boolean
ReDim over2(1 To m) As Boolean
ReDim list(1 To m, 1 To 4) As String
ReDim list1(1 To m, 1 To 5) As String
ReDim result(1 To m, 1 To 5) As String
p = 0
For i = 1 To m
s = 0
If over(i) = False Then
p = p + 1
s = s + 1
list(p, 1) = arr(i, 1)
list(p, 2) = arr(i, 2)
list(p, 3) = arr(i, 3)
over(i) = True
For j = 1 To m
If i <> j And over(j) = False Then
src = Trim(arr(i, 1)) & Trim(arr(i, 2)) & Trim(arr(i, 3))
des = Trim(arr(j, 1)) & Trim(arr(j, 2)) & Trim(arr(j, 3))
If src = des Then
p = p + 1
s = s + 1
list(p, 1) = arr(j, 1)
list(p, 2) = arr(j, 2)
list(p, 3) = arr(j, 3)
over(j) = True
End If
End If
Next
For n = p To p - s + 1 Step -1
list(n, 4) = s
Next
End If
Next
'--------------------------------------------
p = 0
For i = 1 To m
s = 0
If over1(i) = False Then
p = p + 1
s = s + 1
list1(p, 1) = list(i, 1)
list1(p, 2) = list(i, 2)
list1(p, 3) = list(i, 3)
list1(p, 4) = list(i, 4)
over1(i) = True
For j = 1 To m
If i <> j And over1(j) = False Then
src = Trim(list(i, 2)) & Trim(list(i, 3))
des = Trim(list(j, 2)) & Trim(list(j, 3))
If src = des Then
p = p + 1
s = s + 1
list1(p, 1) = list(j, 1)
list1(p, 2) = list(j, 2)
list1(p, 3) = list(j, 3)
list1(p, 4) = list(j, 4)
over1(j) = True
End If
End If
Next
For n = p To p - s + 1 Step -1
list1(n, 5) = s
Next
End If
Next
'--------------------------------------------
p = 0
For i = 1 To m
If over2(i) = False Then
p = p + 1
result(p, 1) = list1(i, 1)
result(p, 2) = list1(i, 2)
result(p, 3) = list1(i, 3)
result(p, 4) = list1(i, 4)
result(p, 5) = list1(i, 5)
over2(i) = True
For j = 1 To m
If i <> j And over2(j) = False Then
src = Trim(list1(i, 1)) & Trim(list1(i, 2)) & Trim(list1(i, 3))
des = Trim(list1(j, 1)) & Trim(list1(j, 2)) & Trim(list1(j, 3))
If src = des Then
over2(j) = True
Else
Exit For
End If
End If
Next
End If
Next
'----------------------------------------------------
ReDim sort(1 To p, 1 To 5) As String
ReDim sort1(1 To p, 1 To 9) As String
ReDim over3(1 To p) As Boolean
m = 0
pp = 0
For i = 1 To p
s = 0
If over3(i) = False Then
m = m + 1
s = s + 1
sort(m, 1) = result(i, 1)
sort(m, 2) = result(i, 2)
sort(m, 3) = result(i, 3)
sort(m, 4) = result(i, 4)
sort(m, 5) = result(i, 5)
over3(i) = True
For j = 1 To p
If i <> j And over3(j) = False Then
src = Trim(result(i, 2)) & Trim(result(i, 3))
des = Trim(result(j, 2)) & Trim(result(j, 3))
If src = des Then
m = m + 1
s = s + 1
sort(m, 1) = result(j, 1)
sort(m, 2) = result(j, 2)
sort(m, 3) = result(j, 3)
sort(m, 4) = result(j, 4)
sort(m, 5) = result(j, 5)
over3(j) = True
End If
End If
Next
For n = m - s + 1 To m - 1
For n1 = n + 1 To m
If CInt(sort(n, 4)) < CInt(sort(n1, 4)) Then
For tt = 1 To 5
temp = sort(n, tt)
sort(n, tt) = sort(n1, tt)
sort(n1, tt) = temp
Next
End If
Next
Next
If s > 3 Then
s1 = 3
Else
s1 = s
End If
pp = pp + 1
For n = 1 To s1
If n = 1 Then
sort1(pp, 1) = sort(m - s + n, 2)
sort1(pp, 2) = sort(m - s + n, 3)
sort1(pp, 3) = sort(m - s + n, 5)
End If
sort1(pp, 2 + 2 * n) = sort(m - s + n, 1)
sort1(pp, 3 + 2 * n) = sort(m - s + n, 4)
Next
End If
Next
'-------------------------------------------
'制表
'-------------------------------------------
Range("d2").Resize(pp, 9) = sort1
End Sub

ldy888

QUOTE:

以下是引用northwolves在2007-11-28 11:37:47的发言：
有空时整一个

期待。。。。。。。。

不知道动态规划能不能做这个？

彭希仁

QUOTE:

以下是引用tycp在2007-11-28 11:55:29的发言：

只用数组!

Sub hz()
Dim i As Integer, p As Integer, j As Integer, m As Integer, n As Integer
Dim s As Integer, n1 As Integer, tt As Integer
Dim over() As Boolean, over1() As Boolean, over2() As Boolean, over3() As Boolean
Dim list() As String, list1() As String, result() As String
Dim sort() As String, sort1() As String, src As String, des As String
Dim arr, temp
Dim pp As Integer, s1 As Integer
With Worksheets("数据")
p = .Range("a65536").End(xlUp).Row
arr = .Range("a2:c" & p)
End With
m = UBound(arr, 1)
ReDim over(1 To m) As Boolean
ReDim over1(1 To m) As Boolean
ReDim over2(1 To m) As Boolean
ReDim list(1 To m, 1 To 4) As String
ReDim list1(1 To m, 1 To 5) As String
ReDim result(1 To m, 1 To 5) As String
p = 0
For i = 1 To m
s = 0
If over(i) = False Then
p = p + 1
s = s + 1
list(p, 1) = arr(i, 1)
list(p, 2) = arr(i, 2)
list(p, 3) = arr(i, 3)
over(i) = True
For j = 1 To m
If i <> j And over(j) = False Then
src = Trim(arr(i, 1)) & Trim(arr(i, 2)) & Trim(arr(i, 3))
des = Trim(arr(j, 1)) & Trim(arr(j, 2)) & Trim(arr(j, 3))
If src = des Then
p = p + 1
s = s + 1
list(p, 1) = arr(j, 1)
list(p, 2) = arr(j, 2)
list(p, 3) = arr(j, 3)
over(j) = True
End If
End If
Next
For n = p To p - s + 1 Step -1
list(n, 4) = s
Next
End If
Next
'--------------------------------------------
p = 0
For i = 1 To m
s = 0
If over1(i) = False Then
p = p + 1
s = s + 1
list1(p, 1) = list(i, 1)
list1(p, 2) = list(i, 2)
list1(p, 3) = list(i, 3)
list1(p, 4) = list(i, 4)
over1(i) = True
For j = 1 To m
If i <> j And over1(j) = False Then
src = Trim(list(i, 2)) & Trim(list(i, 3))
des = Trim(list(j, 2)) & Trim(list(j, 3))
If src = des Then
p = p + 1
s = s + 1
list1(p, 1) = list(j, 1)
list1(p, 2) = list(j, 2)
list1(p, 3) = list(j, 3)
list1(p, 4) = list(j, 4)
over1(j) = True
End If
End If
Next
For n = p To p - s + 1 Step -1
list1(n, 5) = s
Next
End If
Next
'--------------------------------------------
p = 0
For i = 1 To m
If over2(i) = False Then
p = p + 1
result(p, 1) = list1(i, 1)
result(p, 2) = list1(i, 2)
result(p, 3) = list1(i, 3)
result(p, 4) = list1(i, 4)
result(p, 5) = list1(i, 5)
over2(i) = True
For j = 1 To m
If i <> j And over2(j) = False Then
src = Trim(list1(i, 1)) & Trim(list1(i, 2)) & Trim(list1(i, 3))
des = Trim(list1(j, 1)) & Trim(list1(j, 2)) & Trim(list1(j, 3))
If src = des Then
over2(j) = True
Else
Exit For
End If
End If
Next
End If
Next
'----------------------------------------------------
ReDim sort(1 To p, 1 To 5) As String
ReDim sort1(1 To p, 1 To 9) As String
ReDim over3(1 To p) As Boolean
m = 0
pp = 0
For i = 1 To p
s = 0
If over3(i) = False Then
m = m + 1
s = s + 1
sort(m, 1) = result(i, 1)
sort(m, 2) = result(i, 2)
sort(m, 3) = result(i, 3)
sort(m, 4) = result(i, 4)
sort(m, 5) = result(i, 5)
over3(i) = True
For j = 1 To p
If i <> j And over3(j) = False Then
src = Trim(result(i, 2)) & Trim(result(i, 3))
des = Trim(result(j, 2)) & Trim(result(j, 3))
If src = des Then
m = m + 1
s = s + 1
sort(m, 1) = result(j, 1)
sort(m, 2) = result(j, 2)
sort(m, 3) = result(j, 3)
sort(m, 4) = result(j, 4)
sort(m, 5) = result(j, 5)
over3(j) = True
End If
End If
Next
For n = m - s + 1 To m - 1
For n1 = n + 1 To m
If CInt(sort(n, 4)) < CInt(sort(n1, 4)) Then
For tt = 1 To 5
temp = sort(n, tt)
sort(n, tt) = sort(n1, tt)
sort(n1, tt) = temp
Next
End If
Next
Next
If s > 3 Then
s1 = 3
Else
s1 = s
End If
pp = pp + 1
For n = 1 To s1
If n = 1 Then
sort1(pp, 1) = sort(m - s + n, 2)
sort1(pp, 2) = sort(m - s + n, 3)
sort1(pp, 3) = sort(m - s + n, 5)
End If
sort1(pp, 2 + 2 * n) = sort(m - s + n, 1)
sort1(pp, 3 + 2 * n) = sort(m - s + n, 4)
Next
End If
Next
'-------------------------------------------
'制表
'-------------------------------------------
Range("d2").Resize(pp, 9) = sort1
End Sub

强人啊,得用梯子来看.

彭希仁

QUOTE:

以下是引用ldy888在2007-11-28 11:55:36的发言：

期待。。。。。。。。

不知道动态规划能不能做这个？

估计不成,根本不贴边.

tycp

用二维数组做的,比一维数组快很多!

Dim p As Integer, pp As Integer
Dim jxgz() As String, sf() As String

Sub check()
Dim m As Integer
Dim arr
Dim s1 As Integer, s2 As String
Dim over() As Boolean, over1() As Boolean
Dim box() As Integer
With Worksheets("数据")
p = .Range("a65536").End(xlUp).Row
arr = .Range("a2:c" & p)
End With
m = UBound(arr, 1)
ReDim over(1 To m) As Boolean
ReDim over1(1 To m) As Boolean
ReDim jxgz(1 To m) As String
ReDim sf(1 To m) As String

'提取不重复的机型故障-----------------------------------------------------------
p = 0
For i = 1 To m
If over(i) = False Then
p = p + 1
jxgz(p) = Trim(arr(i, 2)) & Trim(arr(i, 3))
over(i) = True
For j = 1 To m
If i <> j And over(j) = False Then
src = Trim(arr(i, 2)) & Trim(arr(i, 3))
des = Trim(arr(j, 2)) & Trim(arr(j, 3))
If src = des Then
over(j) = True
End If
End If
Next
End If
Next
'提取不重复的省份---------------------------------------------------------------
pp = 0
For i = 1 To m
If over1(i) = False Then
pp = pp + 1
sf(pp) = Trim(arr(i, 1))
over1(i) = True
For j = 1 To m
If i <> j And over1(j) = False Then
src = Trim(arr(i, 1))
des = Trim(arr(j, 1))
If src = des Then
over1(j) = True
End If
End If
Next
End If
Next

ReDim box(1 To p, 1 To pp + 1) As Integer
For i = 1 To m
s1 = findnum(Trim(arr(i, 2)) & Trim(arr(i, 3)), True)
box(s1, pp + 1) = box(s1, pp + 1) + 1
s1 = findnum(Trim(arr(i, 2)) & Trim(arr(i, 3)), True)
s2 = findnum(Trim(arr(i, 1)), False)
box(s1, s2) = box(s1, s2) + 1
Next

Range("d2").Resize(p, pp + 1) = box

End Sub
Function findnum(str As String, flag As Boolean) As Integer
Dim i As Integer
If flag = True Then
For i = 1 To p
If jxgz(i) = str Then
findnum = i
Exit For
End If
Next
Else
For i = 1 To pp
If sf(i) = str Then
findnum = i
Exit For
End If
Next
End If
End Function