错行对应求和..........

secowu

要对类似空白的地方双击后，才OK

1. 
   
2. 
   
3. Option Explicit
   
4. option private module
   
5. Sub mSumproductAddress()
   
6.     Dim i, j, k As Integer
   
7.     Dim row As Integer
   
8.     Dim mSum As String
   
9.     On Error Resume Next
   
10.     row = 2
    
11.     k = ActiveSheet.Cells(Rows.Count, 1).End(3).row + 2
    
12.     For j = 3 To ActiveSheet.UsedRange.Columns.Count
    
13.         For i = 1 To k - 4 Step 2
    
14. 
    
15.             mSum = mSum & Cells(i + 2, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False) & "*" & Cells(row, j).Address(RowAbsolute:=False, ColumnAbsolute:=False) & "+"
    
16.             row = row + 2
    
17.         Next i
    
18.         Cells(k, j) = "=" & Left(mSum, Len(mSum) - 1)
    
19.         i = 1
    
20.         row = 2
    
21.         mSum = ""
    
22.     Next j
    
23. End Sub
    
24. 
    
25. Sub mSumproduct()
    
26.      Dim i, j, k As Integer
    
27.      Dim row As Integer
    
28.      Dim mSum As Integer
    
29.      On Error Resume Next
    
30.      row = 2
    
31.      k = ActiveSheet.Cells(Rows.Count, 1).End(3).row + 1
    
32.      For j = 3 To ActiveSheet.UsedRange.Columns.Count
    
33.      For i = 1 To ActiveSheet.Cells(Rows.Count, 1).End(3).row Step 2
    
34.           mSum = mSum + Cells(i + 2, 1) * Cells(row, j)
    
35.           row = row + 2
    
36.      Next i
    
37.            Cells(k, j) = mSum
    
38.            i = 1
    
39.            row = 2
    
40.            mSum = 0
    
41.      Next j
    
42. End Sub
    
43. 
    
44. Sub temp()
    
45.     Call mSumproduct
    
46.     Call mSumproductAddress
    
47. End Sub
    

复制代码

[ 本帖最后由 secowu 于 2010-8-31 20:59 编辑 ]

secowu

没有头绪了，是不是先将A列放入数组，判断B列中包含有PC标识的对应C列的值再写入数组
然后，将此两数组的值对应的range提取出来，再组合成sum(x*y,x1*y1....)?

dsmch

不大明白，如仅仅两个错行，直接写公式；如很多，试试offset

secowu

原帖由 dsmch 于 2010-8-31 16:06 发表
不大明白，如仅仅两个错行，直接写公式；如很多，试试offset

不确定是几行。有多也有少。
offset如何写？

dsmch

上传个附件，方便测试代码。

secowu

原帖由 dsmch 于 2010-8-31 16:08 发表
上传个附件，方便测试代码。

附件在一楼，test.rar

zhangjimfu

Sub sumproduct()
     Dim i As Integer
     Dim row As Integer
     Dim sum As Integer
     On Error Resume Next
     row = 2
     For i = 1 To 10 Step 2
          sum = sum + Cells(i + 2, 1) * Cells(row, 3)
          row = row + 2
     Next i
           Cells(6, 3) = sum
End Sub

secowu

原帖由 zhangjimfu 于 2010-8-31 16:11 发表
Sub sumproduct()
     Dim i As Integer
     Dim row As Integer
     Dim sum As Integer
     On Error Resume Next
     row = 2
     For i = 1 To 10 Step 2
          sum = sum + Cells(i + 2, 1) * ...

非常感谢，能否做成单元格保留公式的情况？而非直接出结果。当然，你这个直接出结果很棒。

dsmch

Function aa()
Application.Volatile
For Each cel In Range("a2:a" & Range("a65536").End(xlUp).Row)
If cel <> "" Then s = s + Val(cel) * Val(cel.Offset(-1, 2))
Next
aa = s
End Function

secowu

原帖由 dsmch 于 2010-8-31 16:17 发表
Function aa()
Application.Volatile
For Each cel In Range("a2:a" & Range("a65536").End(xlUp).Row)
If cel  "" Then s = s + Val(cel) * Val(cel.Offset(-1, 2))
Next
aa = s
End Function

你也是直接出结果的，有没有公式版本？