[已解决]按条件自动筛选数据并转置显示结果！

sayhi1984

baksy 发表于 2013-12-19 15:29
1. "数值差范围在0.03"是什么意思？
2. “随机使用一个数值”的话有必要排序吗？

1、比如：1.051、1.151、1.121，只有1.051和1.121符合条件。
2、最后转置的结果中，数值由低到高显示。

爱疯

Sub Click()
    Dim A, d, i, k, t
    Set d = CreateObject("scripting.dictionary")
    A = [B3:D15]
    For i = 2 To UBound(A)
        t = A(i, 1) & A(i, 2)
        d(t) = d(t) & "," & A(i, 3)
    Next i
    k = d.keys: t = d.items
    For i = 0 To UBound(t)
        t(i) = IIf(f(t(i)) = "", "无", f(t(i)))
    Next i
   
    Range("c17:d65536").ClearContents
    Range("c17").Resize(UBound(k) + 1) = Application.Transpose(k)
    Range("d17").Resize(UBound(k) + 1) = Application.Transpose(t)
End Sub


'求某个key中的值
Function f(s)
    Dim B, C, i, x
   
    '转为数值数组，并排序
    B = Split(s, ",")
    ReDim C(UBound(B))
    For i = 1 To UBound(B)
        C(i) = B(i) * 1
    Next i
    Call SelectionSort(C)
   
    '只保留第一次符合要求的值
    x = False
    For i = 1 To UBound(C) - 1
        If Abs(C(i) - C(i + 1)) > 0.03 Then
            If x Then x = False
        Else
            If x = False Then x = True: f = f & "," & C(i)
        End If
    Next i
   
    f = Mid(f, 2)
End Function



Sub SelectionSort(arr)
    Dim i, j, t, k
    For i = LBound(arr) To UBound(arr) - 1
        k = i
        For j = i + 1 To UBound(arr)
            If arr(k) > arr(j) Then k = j    '升序
        Next
        If k <> i Then t = arr(k): arr(k) = arr(i): arr(i) = t
    Next
End Sub

自动筛选转置2.rar (14.19 KB, 下载次数: 8)

2013-12-20 09:58 上传

点击文件名下载附件



比如候月下，我是挑符合条件中的最小值，也就是符合条件中第1次出现的值。

sayhi1984

感谢爱疯老师，正在测试！

sayhi1984

爱疯 发表于 2013-12-20 10:05
Sub Click()
    Dim A, d, i, k, t
    Set d = CreateObject("scripting.dictionary")

感谢老师，效果真的没的说！我新上传了一个文件，自己学着加了一个模块，但是错误百出，最上面的代码看不太大懂，老师看能不能帮我完善一下呢？最好能有相关的注释，便于理解，呵呵。

0.zip (30.15 KB, 下载次数: 3)

2013-12-20 13:54 上传

点击文件名下载附件

爱疯

0B.rar (28.26 KB, 下载次数: 11)

2013-12-20 15:02 上传

点击文件名下载附件


如果结果不放在“从J10开始往下的两列”，就改最后3句。

        .Range("J10:K65536").ClearContents
        .Range("J10").Resize(UBound(k) + 1) = Application.Transpose(k)
        .Range("K10").Resize(UBound(k) + 1) = Application.Transpose(t)

sayhi1984

爱疯 发表于 2013-12-20 15:05
如果结果不放在“从J10开始往下的两列”，就改最后3句。

        .Range("J10:K65536").ClearCont ...

感谢爱疯老师指导，如果在此基础上，将E列的“次数”添加在数值后，如557.311重复16次、561.094重复18次……
是不是在这段代码中修改？将重复次数最大值与同线名、同行别一同放在条件里，代码怎么改呢？

      For i = 2 To UBound(A)
            t = A(i, 1) & A(i, 2)
            d(t) = d(t) & "、" & A(i, 3)
        Next i
        k = d.keys: t = d.items
        For i = 0 To UBound(t)
            t(i) = IIf(f(t(i)) = "", "无", f(t(i)))
        Next i

类似的如果只有两列上方代码又如何改呢？

爱疯

1）在车载重点工作表里，假如第26,27行是符合的内容，现在将E列的“次数”添加在数值后
可他们前3列都一样，那该添加16，还是17，还是随便选，还是什么规则？



2）结果放在第5到第9行，因为现在只有5项，不要紧。
但如果有20项，不就把数据源的内容覆盖掉了？

sayhi1984

爱疯 发表于 2013-12-20 15:54
1）在车载重点工作表里，假如第26,27行是符合的内容，现在将E列的“次数”添加在数值后
可他们前3列都一样 ...

回版主：

1、由次数最大的（16、17......等）确定前面26、27行的内容，比如618.019（16）和618.011（15），那么就选定为：618.019重复16次

2、呵呵，这个我已经限制了，南同蒲上、南同蒲下、侯月上、侯月下、侯西，只有5行，斑竹费心了！

爱疯

0d.rar (27.18 KB, 下载次数: 6)

2013-12-20 16:29 上传

点击文件名下载附件

不是你说的选择最大，我没理解你说的意思。

我还是按12楼的方式来选的，只不过带上了次数。这样可以吗

sayhi1984

爱疯 发表于 2013-12-20 16:30
不是你说的选择最大，我没理解你说的意思。

我还是按12楼的方式来选的，只不过带上了次数。这样可以 ...

爱疯老师，也就是相同线名、行别的误差范围小于0.03的数值，选取填充结果的值，起决定因素的是次数列的最大的那个。

另外，我修改为红色内容后，就出错了，这和字符串太长一个个输出有关吗？

1. For i = 2 To UBound(A)
   
2. t = A(i, 1) & A(i, 2)
   
3. d(t) = d(t) & "、" & A(i, 3) & "重复" & A(i, 4) & "次"
   
4. Next i
   
5. k = d.keys: t = d.items
   
6. For i = 0 To UBound(t)
   
7. t(i) = IIf(f(t(i)) = "", "无", f(t(i)))
   
8. Next i
   
9. .Range("B5:D9").ClearContents
   
10. .Range("B5").Resize(UBound(k) + 1) = Application.Transpose(k)
    
11. For i = 0 To UBound(t)
    
12. Cells(i + 5, 4) = t(i)
    
13. Next i
    
14. End With
    
15. End Sub
    
16. 
    
17. Function f(s)
    
18. Dim B, C, i, x
    
19. B = Split(s, "、")
    
20. ReDim C(UBound(B))
    
21. For i = 1 To UBound(B)
    
22. C(i) = Split(B(i), "(")(0) * 1
    

复制代码