[已解决]求助“定位到指定单元格，并输入不规则求和公式进行运算”的VBA 代码

席可茵

求助“定位到指定单元格，并输入不规则求和公式进行运算”的VBA 代码

如附件：定位到“K3”单元格，输入不规则求和公式=SUM(J3:J4)                                                               
           再定位到“K5”单元格，输入不规则求和公式=SUM(J5:J7)                                                               
           再定位到“K8”单元格，输入不规则求和公式=SUM(J8:J16)                                                               
如此一直循环求和运算到“K247”单元格终止                                                                       
                                                                       
定位规律：        对应A列单元格＝“[P]产品”的不为空值的K列单元格或 K列由K3开始打底色的不为空值的单元格                                                               
不规则求和公式：＝一个[P]产品值+多个[D]材料值                                                                       

最佳答案

月排行榜 / 总排行榜

scl5801

2016-6-30 16:41

席可茵 发表于 2016-6-30 15:15
能把K列的结果值显示为公式吗？如K8单元格显示为“=SUM(J8:J16)”

Sub zj()
Dim arr, i%, x
r = Sheet1.Range("a65536").End(3).Row
arr = Sheet1.Range("a3:k" & r)
For i = UBound(arr) To 1 Step -1
     If arr(i, 1) Like "*产品*" Then
        arr(i, 11) = "=sum(j" & i + 2 & ":j" & i + 2 + x & ")"
         x = 0
    Else
        x = x + 1
     End If
Next i
[a3].Resize(UBound(arr), 11) = arr
End Sub

跳转到最佳答案楼层

席可茵

补充附件

心正意诚身修

=IF(G3="已审核",SUM(INDIRECT("J"&ROW()&":J"&IFERROR(MATCH($G$3,G4:G23,)+ROW()-1,4^8))),"")
用函數做一下。我是03版，沒有IFERROR.就不上傳附件了。

心正意诚身修

也許你也是03版。換個03版可以用的。
=IF(G3="已审核",SUM(INDIRECT("J"&ROW()&":J"&IF(ISERROR(MATCH($G$3,G4:G23,)),4^8,MATCH($G$3,G4:G23,)+ROW()-1))),"")

席可茵

谢谢！“心正意诚身修”你的教我的函数公式，这样也可以达到要求，不知道有没有更简单更直接的VBA代码能完，如用变量加上循环的简单代码使用宏完成。

scl5801

席可茵 发表于 2016-6-29 15:15
谢谢！“心正意诚身修”你的教我的函数公式，这样也可以达到要求，不知道有没有更简单更直接的VBA代码能完， ...

Sub zj()
Dim arr, i%, j, x
arr = Sheet1.Range("a3:k" & Sheet1.Range("a65536").End(3).Row)
For i = 1 To UBound(arr)
   If arr(i, 1) <> "[P]产品" Then
      x = x + arr(i, 10)
   Else
      j = i
      x = 0
      x = x + arr(i, 10)
   End If
   arr(j, 11) = x
Next i
[A3].Resize(UBound(arr), 11) = arr
End Sub

席可茵

scl5801 发表于 2016-6-29 17:39
Sub zj()
Dim arr, i%, j, x
arr = Sheet1.Range("a3:k" & Sheet1.Range("a65536").End(3).Row)

能把值改为公式显现吗？

scl5801

席可茵 发表于 2016-6-30 09:13
能把值改为公式显现吗？

借了“心正意诚身修”的公式，不过我不建议用公式显现，因为这样会影响表格的反应速度。
Sub zj()
Dim arr, i%, j, x
arr = Sheet1.Range("a3:k" & Sheet1.Range("a65536").End(3).Row)
For i = 1 To UBound(arr)
    If arr(i, 1) = "[P]产品" Then
      arr(i, 11) = "=IF(RC[-4]=""已审核"",SUM(INDIRECT(""J""&ROW()&"":J""&IF(ISERROR(MATCH(R3C7,R[1]C[-4]:R[20]C[-4],)),4^8,MATCH(R3C7,R[1]C[-4]:R[20]C[-4],)+ROW()-1))),"""")"
    End If
Next i
[A3].Resize(UBound(arr), 11) = arr
End Sub

席可茵

scl5801 发表于 2016-6-30 09:49
借了“心正意诚身修”的公式，不过我不建议用公式显现，因为这样会影响表格的反应速度。
Sub zj()
Dim ...

我原J列的公式可以不动吗，然后K列的显示为求各和公式，如K3单元格显示公式“=SUM(J3:J4)”、如K5单元显示公式 “=SUM(J5:J7)”、如K8单元显示公式 “=SUM(J8:J16)”、

chenye_guan

Sub add()
For Each Rng In Range("a:a")
  If Rng = "[P]产品" Then
    t = Rng.Row
    Cells(Rng.Row, "k") = Cells(Rng.Row, "j")
    Do
      t = t + 1
      If (Cells(t, 1) = "[P]产品") Then Exit Do
      If (Cells(t, 1) = "") Then Exit Do
      Cells(Rng.Row, "k") = Cells(Rng.Row, "k") + Cells(t, "j")
    Loop
  End If
Next
End Sub