求用自定义函数达到附件黄色公式相同的结果

卢嘉轩

求用自定义函数达到附件黄色公式相同的结果.rar (8.41 KB, 下载次数: 10)

2023-3-17 18:43 上传

点击文件名下载附件

求用自定义函数达到附件黄色公式相同的结果.

dambcer

                                                           

卢嘉轩

dambcer 发表于 2023-3-17 19:58

三个参数，条件区域，条件，返回区域。

卢嘉轩

卢嘉轩 发表于 2023-3-17 20:15
三个参数，条件区域，条件，返回区域。

合并单元格能写进数组？

卢嘉轩

Function MyFunction(rng1 As Range)
arr1 = Application.WorksheetFunction.Row(rng1)
  MyFunction = Application.WorksheetFunction.Lookup(arr1, arr1 / rng1 <> "", rng1)
End Function

卢嘉轩

为什么不支持这种写法？

lushang2018

1. Sub 测试()  ''答题专用套路--by:学习使我快乐
   
2.     Dim i, j, k, m, n, arr, brr, crr, drr
   
3.     Dim r As Range, rng As Range
   
4.     Sheet1.Activate
   
5.     Dim dic As Object, key As String, keys, items
   
6.     Set dic = CreateObject("scripting.dictionary")
   
7.     For i = 2 To 12
   
8.         Set rng = Range("A" & i)
   
9.         If rng.MergeArea.Count > 1 Then
   
10.             For k = 1 To rng.MergeArea.Count
    
11.                 Set r = rng.Range("B" & k)
    
12.                 If r.MergeArea.Count > 1 Then
    
13.                     For j = 1 To r.MergeArea.Count
    
14.                         key = rng.Cells(1, 1) & r.Cells(1, 1)
    
15.                         dic(key) = dic(key) + rng.Cells(k + j - 1, 3)
    
16.                     Next
    
17.                     k = k + r.MergeArea.Count - 1
    
18.                 Else
    
19.                     key = rng.Cells(1, 1) & r.Cells(1, 1)
    
20.                     dic(key) = dic(key) + rng.Cells(k, 3)
    
21.                 End If
    
22.             Next
    
23.             i = i + rng.MergeArea.Count - 1
    
24.         End If
    
25.     Next
    
26.     arr = Range("E1").CurrentRegion
    
27.     For i = 2 To UBound(arr)
    
28.         key = arr(i, 1) & arr(i, 2)
    
29.         arr(i, 4) = dic(key)
    
30.     Next
    
31.     Range("E1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
32. End Sub
    

复制代码

lushang2018

试一试这个

卢嘉轩

lushang2018 发表于 2023-3-18 22:35
试一试这个

能做成自定义函数吗？

niko88819

G2 单元格公式,下拉

1. =mergeSum($A$2:$A$20,$B$2:$B$20,$C$2:$C$20,E2,F2)

复制代码

1. 
   
2. Function mergeSum(A As Range, B As Range, C As Range, E As Variant, F As Variant) As Double
   
3. Dim i As Long
   
4. Dim vA, vB
   
5. Dim sum_product As Double
   
6. For i = 1 To C.Cells.Count
   
7.     Debug.Print "i: ", i, A.Cells(i), B.Cells(i), C.Cells(i)
   
8.     If A.Cells(i).Cells(1, 1).Value <> "" Then vA = A.Cells(i).Cells(1, 1).Value
   
9.     If B.Cells(i).Cells(1, 1).Value <> "" Then vB = B.Cells(i).Cells(1, 1).Value
   
10.     If vA = E.Value And vB = F.Value Then
    
11.         sum_product = sum_product + C.Cells(i).Value
    
12.     End If
    
13. Next i
    
14. mergeSum = sum_product
    
15. End Function

复制代码