请老师再帮我写一个按位置统计的代码

hbhsfeng

表格中有很多数据，按位置统计，并把统计结果填在表格里。
表格里面有说明。

xiangbaoan

Sub test()
Dim ar, br(9, 6), s$, r&, c%
ar = Range([d3:j3], [d3:j3].End(xlDown))
s = [d1] & [j1]
For r = 1 To UBound(ar) - 1
    If ar(r, 1) & ar(r, 7) = s Then
        For c = 1 To 7
            br(ar(r + 1, c), c - 1) = br(ar(r + 1, c), c - 1) + 1
        Next
    End If
Next
[l3].Resize(10, 7) = br
End Sub

hbhsfeng

xiangbaoan 发表于 2018-10-5 17:29
Sub test()
Dim ar, br(9, 6), s$, r&, c%
ar = Range([d3:j3], [d3:j3].End(xlDown))

测试正确，这么快就写好了。太感谢你了!

hbhsfeng

如果是第一位与第六位查找，是不是改s = [d1] & [i1]？

xiangbaoan

hbhsfeng 发表于 2018-10-5 17:37
如果是第一位与第六位查找，是不是改s = [d1] & ？

恭喜你，答对了！
补一个通用的，条件可是1 到 7

Private Sub CommandButton1_Click()
Dim tp, tm(), ar, br(9, 6), t$, s$, r&, c%, n%
ar = [d1:j1]
For c = 1 To 7
    If Len(ar(1, c)) Then
        s = s & ar(1, c)
        n = n + 1
        ReDim Preserve tm(1 To n)
        tm(n) = c
    End If
Next
tp = Range([d3:j3], [d3:j3].End(xlDown))
For r = 1 To UBound(tp) - 1
    t = ""
    For c = 1 To UBound(tm)
        t = t & tp(r, tm(c))
    Next
    If t = s Then
        For c = 1 To 7
            br(tp(r + 1, c), c - 1) = br(tp(r + 1, c), c - 1) + 1
        Next
    End If
Next
[l3].Resize(10, 7) = br
End Sub

hbhsfeng

今天鲜花送完了，明天再送。