[已解决]自定函数返回相同的个数及实际数。

excelpxfans001

自定函数返回相同的个数及实际数。

最佳答案

月排行榜 / 总排行榜

爱疯

2016-3-5 14:25

'限制：
'1）参数是一行区域
'2）各参数包含的元素个数相同
Function SameNumber(ParamArray A() As Variant)
    Dim B, C, D, i, j

    C = A(0): D = C
    ReDim C(1 To 1, 1 To UBound(C, 2))
    For i = 0 To UBound(A)
        B = A(i)
        For j = LBound(C, 2) To UBound(C, 2)
            C(1, j) = IIf(i, C(1, j) = B(1, j), B(1, j))
        Next j
    Next i

    For j = LBound(C, 2) To UBound(C, 2)
        If C(1, j) Then SameNumber = SameNumber + 1
    Next j
    SameNumber = SameNumber & List(C, D)
End Function

'返回实际数字的列表
Function List(C, D) As String
    Dim j
    For j = LBound(C, 2) To UBound(C, 2)
        If C(1, j) Then List = List & "," & D(1, j)
    Next j
    List = "(" & Mid(List, 2) & ")"
End Function

求相同5.rar (11.03 KB, 下载次数: 14)

2016-3-5 14:24 上传

点击文件名下载附件

跳转到最佳答案楼层

excelpxfans001

有老师可解么

爱疯

求相同2.rar (11.01 KB, 下载次数: 6)

2016-3-5 12:47 上传

点击文件名下载附件

Function SameNumber(ParamArray A() As Variant) As Integer
    Dim B(9), C(9), x, i, j ', str

    For i = 0 To UBound(A)
        If IsArray(A(i)) Then
            '1）去重复
            Erase B
            For Each x In A(i)
                B(x) = 1
            Next

            '2）累计不重复的项
            For j = 0 To 9
                C(j) = C(j) + B(j)
            Next
        Else
            '2）累计不重复的项
            C(A(i)) = C(A(i)) + 1
        End If
    Next i

    '3）找出各参数里都有的项
    For i = 0 To UBound(C)
        If C(i) = UBound(A) + 1 Then SameNumber = SameNumber + 1 ': str = str & "," & i
    Next i
    'Debug.Print Mid(str, 2)
End Function

excelpxfans001

爱疯 发表于 2016-3-5 12:48
Function SameNumber(ParamArray A() As Variant) As Integer
    Dim B(9), C(9), x, i, j ', st ...

版主你好，从左至右要同位置相同的才算。

爱疯

excelpxfans001 发表于 2016-3-5 13:11
版主你好，从左至右要同位置相同的才算。

'限制：
'1）参数是一行区域
'2）各参数包含的元素个数相同
Function SameNumber(ParamArray A() As Variant) As Integer
    Dim B, C, i, j

    C = A(0)
    ReDim C(1 To 1, 1 To UBound(C, 2))
    For i = 0 To UBound(A)
        B = A(i).Value
        For j = LBound(C, 2) To UBound(C, 2)
            If i = 0 Then
                C(1, j) = B(1, j)
            Else
                C(1, j) = (C(1, j) = B(1, j))
            End If
        Next j
    Next i

    For j = LBound(C, 2) To UBound(C, 2)
        If C(1, j) Then SameNumber = SameNumber + 1
    Next j
End Function

求相同4.rar (10.62 KB, 下载次数: 8)

2016-3-5 14:05 上传

点击文件名下载附件


有这2条限制，可以吗

excelpxfans001

爱疯 发表于 2016-3-5 14:06
'限制：
'1）参数是一行区域
'2）各参数包含的元素个数相同

谢谢版主，个数已求出。具体相同数值可以跟在()里列出来么。

爱疯

比如，=SameNumber(M15:V15,O19:X19)

单元格里返回的结果是什么样子？你手动给出看下

excelpxfans001

爱疯 发表于 2016-3-5 14:15
比如，=SameNumber(M15:V15,O19:X19)

单元格里返回的结果是什么样子？你手动给出看下

比如示例是相同个数是2个，具体数值是7，6.   则返回结果为： 2(7,6)  

爱疯

'限制：
'1）参数是一行区域
'2）各参数包含的元素个数相同
Function SameNumber(ParamArray A() As Variant)
    Dim B, C, D, i, j

    C = A(0): D = C
    ReDim C(1 To 1, 1 To UBound(C, 2))
    For i = 0 To UBound(A)
        B = A(i)
        For j = LBound(C, 2) To UBound(C, 2)
            C(1, j) = IIf(i, C(1, j) = B(1, j), B(1, j))
        Next j
    Next i

    For j = LBound(C, 2) To UBound(C, 2)
        If C(1, j) Then SameNumber = SameNumber + 1
    Next j
    SameNumber = SameNumber & List(C, D)
End Function

'返回实际数字的列表
Function List(C, D) As String
    Dim j
    For j = LBound(C, 2) To UBound(C, 2)
        If C(1, j) Then List = List & "," & D(1, j)
    Next j
    List = "(" & Mid(List, 2) & ")"
End Function

求相同5.rar (11.03 KB, 下载次数: 14)

2016-3-5 14:24 上传

点击文件名下载附件

excelpxfans001

爱疯 发表于 2016-3-5 14:25
'限制：
'1）参数是一行区域
'2）各参数包含的元素个数相同

谢谢老师，结果对的。  只是返回的结果单元格右上角好像有个什么相邻单元格。