[已解决]怎么求和？

大灰狼1976 · 发表于 2017-5-15 17:36

一样的，字典不适用。

Sub aaa()
Dim arr, brr, r1&, r2&, c1&, c2
arr = Range("e6:i" & [i65536].End(3).Row)
ReDim brr(1 To UBound(arr) * 2, 1 To 9)
r1 = 1: r2 = 1: c2 = 3
For i = 1 To UBound(arr)
If InStr(arr(i, 5), "a") Then
c1 = c1 + 1
If c1 = 4 Then
c1 = 1
r1 = r1 + 6
End If
brr(r1, c1) = arr(i, 3)
brr(r1, 7) = brr(r1, 7) + arr(i, 3)
brr(r1, 9) = brr(r1, 9) + arr(i, 3)
End If
If InStr(arr(i, 5), "b") Then
c2 = c2 + 1
If c2 = 7 Then
c2 = 4
r2 = r2 + 6
End If
brr(r2, c2) = arr(i, 3)
brr(r2, 8) = brr(r2, 8) + arr(i, 3)
brr(r2, 9) = brr(r2, 9) + arr(i, 3)
End If
Next i
[k6].Resize(IIf(r1 > r2, r1, r2), 9) = brr
End Sub

复制代码

dfsfsa · 发表于 2017-5-15 21:27

本帖最后由 dfsfsa 于 2017-5-18 12:28 编辑

大灰狼1976 发表于 2017-5-15 17:36
一样的，字典不适用。

帮忙再改下代码？

dfsfsa · 发表于 2017-5-17 13:07

大灰狼1976 发表于 2017-5-15 17:36
一样的，字典不适用。

帮个忙？？

大灰狼1976 · 发表于 2017-5-17 16:14

在原代码上修改了一下，没有测试，你试试看有无问题。

Sub aaa()
Dim arr, brr, r1&, r2&, c1&, c2
arr = Range("e6:i" & [i65536].End(3).Row)
ReDim brr(1 To UBound(arr) * 2, 1 To 9)
r1 = 1: r2 = 1: c2 = 3
For i = 1 To UBound(arr)
If InStr(arr(i, 5), "a") Then
c1 = c1 + 1
If c1 = 4 Then
c1 = 1
r1 = r1 + 6
End If
brr(r1, c1) = arr(i, 3)
brr(r1, 7) = brr(r1, 7) + arr(i, 3)/2
brr(r1, 9) = brr(r1, 9) + arr(i, 3)/4
End If
If InStr(arr(i, 5), "b") Then
c2 = c2 + 1
If c2 = 7 Then
c2 = 4
r2 = r2 + 6
End If
brr(r2, c2) = arr(i, 3)
brr(r2, 8) = brr(r2, 8) + arr(i, 3)/2
brr(r2, 9) = brr(r2, 9) + arr(i, 3)/4
End If
Next i
[k6].Resize(IIf(r1 > r2, r1, r2), 9) = brr
End Sub

复制代码

dfsfsa · 发表于 2017-5-17 16:55

本帖最后由 dfsfsa 于 2017-5-18 12:28 编辑

大灰狼1976 发表于 2017-5-17 16:14
在原代码上修改了一下，没有测试，你试试看有无问题。

结果不对，你测试一下

大灰狼1976 · 发表于 2017-5-17 17:05

我试了一下是正确的，举例：
第一行包含a的数据为500、530、300，求和为1330，除以2以后为665，包含b的数据为20、25、30，求和为75，除以2以后为37.5，包含ab的数据求和为1405，除以4以后为351.25
跟代码运行结果是一致的。

dfsfsa · 发表于 2017-6-16 10:07

Sub Macro1()
Dim d1 As Object, d2 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
arr = Range("E6:I" & Range("E65536").End(xlUp).Row)
Dim brr: ReDim brr(1 To UBound(arr, 1), 1 To 7)
For i = 1 To UBound(arr, 1)
      If InStr(arr(i, 5), "a") <> 0 Then
         If d1.exists(arr(i, 1) & ",a") Then
            d1(arr(i, 1) & ",a") = d1(arr(i, 1) & ",a") & "," & arr(i, 3)
         Else
            d1(arr(i, 1) & ",a") = arr(i, 3)
         End If
      ElseIf InStr(arr(i, 5), "b") <> 0 Then
         If d2.exists(arr(i, 1) & ",b") Then
            d2(arr(i, 1) & ",b") = d2(arr(i, 1) & ",b") & "," & arr(i, 3)
         Else
            d2(arr(i, 1) & ",b") = arr(i, 3)
         End If
      End If
Next
key1 = Application.Index(arr, , 1)
For Each k1 In d1.keys
      r = Application.Match(Split(k1, ",")(0), key1, 0)
      crr = Split(d1(k1), ",")
      For i = 0 To 1
         brr(r, i + 1) = Val(crr(i))
      Next
Next
For Each k2 In d2.keys
      r = Application.Match(Split(k2, ",")(0), key1, 0)
      crr = Split(d2(k2), ",")
      For i = 0 To 1
         brr(r, i + 3) = Val(crr(i))
      Next
      brr(r, 5) = brr(r, 1) + brr(r, 2)
      brr(r, 6) = brr(r, 3) + brr(r, 4)
      brr(r, 7) = brr(r, 5) + brr(r, 6)
Next
Range("k6").Resize(UBound(brr, 1), 7) = brr
End Sub

dfsfsa · 发表于 2017-6-16 10:09

Sub Macro2()
ReDim ar(1 To 100, 1 To 7)
For i = 6 To 17
n = n + 1
If Cells(i, "E") <> Cells(i - 1, "E") Then
      s = Application.CountIf(Range("E1:E1000"), Cells(i, "E"))
      For j = 6 To 17
         If Cells(j, "I") Like "*a*" And Cells(i, "E") = Cells(j, "E") Then g = g + 1: ar(n, g) = Cells(j, "G")
      Next
      For j = 6 To 17
         If Cells(j, "I") Like "*b*" And Cells(i, "E") = Cells(j, "E") Then g = g + 1: ar(n, g) = Cells(j, "G")
      Next
         ar(n, 5) = ar(n, 1) + ar(n, 2)
         ar(n, 6) = ar(n, 3) + ar(n, 4)
         ar(n, 7) = ar(n, 5) + ar(n, 6)
      g = 0
End If
Next i
Cells(6, "K").Resize(n, 7) = ar
End Sub

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

[已解决]怎么求和？

评分