本帖最后由 On_fire 于 2017-5-10 13:50 编辑
这难题是一种 [线性关系 ] 的统计
原始资料 (同1行, 4列, 比如:有A, B, C, D, 共4个原素):
1.组合就是大写项生成小写项 ( 截图-任2 )
2.对小写项进行分类汇总(计数)
分类汇总: 统计部分 统计1,条件(原素)及结果(原素), 必需顺序 统计2,条件(原素)及结果(原素), 没有顺序要求
- Sub aaa()
- Dim arr, s$, s1$, i&, j&, k&, d As Object, brr, crr, a&, b&, c&, n&, r&, r1&, mx$, rx&, tmp$
- Set d = CreateObject("scripting.dictionary")
- arr = Range("a4:g" & [a65536].End(3).Row)
- For i = 1 To UBound(arr)
- For j = 1 To 3
- For k = j To 4
- mx = arr(i, j)
- If mx > arr(i, k) Then
- mx = arr(i, k)
- rx = k
- End If
- Next k
- If mx <> arr(i, j) Then
- tmp = arr(i, j)
- arr(i, j) = arr(i, rx)
- arr(i, rx) = tmp
- End If
- Next j
- Next i
- n = InputBox("Please input ...")
- [j:y].ClearContents
- For k = 1 To 2
- ReDim brr(1 To Application.Combin(4, n) * UBound(arr), 1 To n + 4)
- If k = 2 Then
- For r1 = 2 To UBound(arr)
- If arr(r1, 6) > arr(r1, 7) Then
- tmp = arr(r1, 6)
- arr(r1, 6) = arr(r1, 7)
- arr(r1, 7) = tmp
- End If
- Next r1
- End If
- For i = 1 To UBound(arr)
- For a = 1 To 5 - n
- For b = a + 1 To 6 - n
- For c = b + 1 To 7 - n
- s = arr(i, a) & arr(i, b) & arr(i, 6) & arr(i, 7)
- If n = 3 Then s = s & arr(i, c)
- If Not d.exists(s) Then
- r = r + 1
- d(s) = r
- brr(r, 1) = arr(i, a)
- brr(r, 2) = arr(i, b)
- If n = 3 Then brr(r, 3) = arr(i, c)
- brr(r, n + 2) = arr(i, 6)
- brr(r, n + 3) = arr(i, 7)
- End If
- brr(d(s), n + 4) = brr(d(s), n + 4) + 1
- If n = 2 Then Exit For
- Next c
- Next b
- Next a
- Next i
- d.RemoveAll
- If k = 1 Then [j4].Resize(r, n + 4) = brr Else [s4].Resize(r, n + 4) = brr
- r = 0
- Next k
- End Sub
复制代码
|