[已解决]双条件分批汇总

张雄友 · 发表于 2014-12-16 22:34

双条件分批汇总。

最佳答案

月排行榜 / 总排行榜

dsmch

2014-12-17 06:13

Sub Macro1()
Dim arr, brr, crr, d, w(), i&, j%, s%, n&, n2&
Set d = CreateObject("scripting.dictionary")
Sheet2.Activate
arr = Range("a3").CurrentRegion
brr = Sheet1.Range("a3").CurrentRegion
ReDim crr(1 To 10000, 1 To UBound(arr, 2))
ReDim w(1 To (UBound(arr, 2) - 4) \ 2, 1 To 2)
s = 1
w(s, 1) = 0: w(s, 2) = 5
For j = 7 To UBound(arr, 2) Step 2
s = s + 1
w(s, 1) = Val(arr(1, j)) - 0.5
w(s, 2) = j
Next
For i = 2 To UBound(brr)
zf = brr(i, 3) & "," & brr(i, 4)
If Not d.exists(zf) Then
n = n + 1
d(zf) = n
crr(n, 1) = brr(i, 3)
crr(n, 2) = brr(i, 4)
End If
n2 = d(zf)
crr(n2, 3) = crr(n2, 3) + brr(i, 7)
crr(n2, 4) = crr(n2, 4) + brr(i, 8)
l = Application.Lookup(brr(i, 9), w)
crr(n2, l) = crr(n2, l) + brr(i, 7)
crr(n2, l + 1) = crr(n2, l + 1) + brr(i, 8)
Next
Range("a11").Resize(n, UBound(crr, 2)) = crr
For j = 3 To UBound(crr, 2)
Cells(11 + n, j) = Application.Sum(Cells(11, j).Resize(n))
Next
End Sub

复制代码

跳转到最佳答案楼层

baksy · 发表于 2014-12-17 05:26

E17=SUMPRODUCT((收款明细!$C$4:$C$23=$A17)*(收款明细!$I$4:$I$23>INT((COLUMN()-7)/2)*15+15)*(收款明细!$I$4:$I$23<INT((COLUMN()-7)/2)*15+31),(收款明细!$G$4:$G$23))
F17=SUMPRODUCT((收款明细!$C$4:$C$23=$A17)*(收款明细!$I$4:$I$23>INT((COLUMN()-7)/2)*15+15)*(收款明细!$I$4:$I$23<INT((COLUMN()-7)/2)*15+31),(收款明细!$H$4:$H$23))

复制E17:F17,粘贴到E17:E19区域。

dsmch · 发表于 2014-12-17 06:13

Sub Macro1()
Dim arr, brr, crr, d, w(), i&, j%, s%, n&, n2&
Set d = CreateObject("scripting.dictionary")
Sheet2.Activate
arr = Range("a3").CurrentRegion
brr = Sheet1.Range("a3").CurrentRegion
ReDim crr(1 To 10000, 1 To UBound(arr, 2))
ReDim w(1 To (UBound(arr, 2) - 4) \ 2, 1 To 2)
s = 1
w(s, 1) = 0: w(s, 2) = 5
For j = 7 To UBound(arr, 2) Step 2
s = s + 1
w(s, 1) = Val(arr(1, j)) - 0.5
w(s, 2) = j
Next
For i = 2 To UBound(brr)
zf = brr(i, 3) & "," & brr(i, 4)
If Not d.exists(zf) Then
n = n + 1
d(zf) = n
crr(n, 1) = brr(i, 3)
crr(n, 2) = brr(i, 4)
End If
n2 = d(zf)
crr(n2, 3) = crr(n2, 3) + brr(i, 7)
crr(n2, 4) = crr(n2, 4) + brr(i, 8)
l = Application.Lookup(brr(i, 9), w)
crr(n2, l) = crr(n2, l) + brr(i, 7)
crr(n2, l + 1) = crr(n2, l + 1) + brr(i, 8)
Next
Range("a11").Resize(n, UBound(crr, 2)) = crr
For j = 3 To UBound(crr, 2)
Cells(11 + n, j) = Application.Sum(Cells(11, j).Resize(n))
Next
End Sub

复制代码

dsmch · 发表于 2014-12-17 06:24

………………

张雄友 · 发表于 2014-12-17 06:33

dsmch 发表于 2014-12-17 06:24
………………

有一个问题想问您：早上好。

If Myname <> "ThisWorkbook.Name.xls" And Myname <> "关白.xls" Then '排除几个簿

用以下这种表达： If InStr("关白 ,ThisWorkbook.Name,", Myname & ",") = 0 Then

怎么不行的？怎么才对？

fffox · 发表于 2014-12-17 09:10

应该是
If InStr("关白.xls" & ThisWorkbook.Name , Myname & ",") = 0 Then
吧

JLxiangwei · 发表于 2014-12-17 13:48

Sub test()
Dim dic As Object
Dim arr, Rarr(1 To 100000, 1 To 18)
Dim str$, i&, k&, c&, k1&
arr = Sheet1.Range("a3").CurrentRegion
Set dic = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arr)
      c = 2 * (arr(i, 9) \ 15) + 5
      str = arr(i, 3) & "-" & arr(i, 4)
      If dic.exists(str) Then
         k1 = dic(str)
         Rarr(k1, 3) = Rarr(k1, 3) + arr(i, 7)
         Rarr(k1, 4) = Rarr(k1, 4) + arr(i, 8)
         Rarr(k1, c) = Rarr(k1, c) + arr(i, 7)
         Rarr(k1, c + 1) = Rarr(k1, c + 1) + arr(i, 8)
      Else
         k = k + 1
         dic.Add str, k
         Rarr(k, 1) = arr(i, 3)
         Rarr(k, 2) = arr(i, 4)
         Rarr(k, 3) = arr(i, 7)
         Rarr(k, 4) = arr(i, 8)
         Rarr(k, c) = arr(i, 7)
         Rarr(k, c + 1) = arr(i, 8)
      End If
Next
Range("a17").Resize(k, 18) = Rarr
End Sub

张雄友 · 发表于 2014-12-17 17:57

本帖最后由张雄友于 2014-12-17 17:58 编辑

dsmch 发表于 2014-12-17 06:24
………………

如果没有规律，代码是否适用？就是不是：15天一统计的情况下。

fengxuqiong · 发表于 2014-12-18 20:33

SHEET1C1公式：
=SUMPRODUCT((SHEET2!A$1:A$9&SHEET2!B$1:B$9=A1&B1)*SHEET2!C$1:C$9)

		自动登录	找回密码
密码			注册

[已解决]双条件分批汇总

评分

点评

点评

点评