再次求解决函数参数赋值问题，江南春大哥，来看看

Question

代码江南春已经帮我写了，我也仔细看过了，也发过贴了还是没解决问题
http://topic.csdn.net/u/20100621/15/6057cecd-d700-4f81-9bb9-e1206161e8aa.html
上次写的函数是可以这么用，假如arr0,arr1,arr2是三个数组名称，GetSameElement（arr0，arr1，arr2）可以得到三个数组中共同拥有的元素
但现在比如有5个数组arr0,arr1,arr2,arr3,arr4,
现在随机要求3个或任意其中组合，比如arr0,arr2,arr3怎么把这个信息传递给函数呢？
想法是str=arr0,arr1,arr2 然后将这个整体字符串赋值给GetSameElement(str)，可惜没有结果
相当于，我把这5个数组名称放入一个list,任意选取他们的组合，赋值给函数
有提示用callbyname，不能解决
原代码如下
Sub Main()
    Debug.Print GetSameElement(Array(1, 2, 3, 4, 5), Array(1, 2, 9), Array(1, 2, 10))
End SubFunction GetSameElement(ParamArray vParamArray()) As String
    Dim strArr() As String
    Dim i As Long, j As Long, k As Long
    Dim strResult As String
    Dim nVal As Long
    Dim blnSame As Boolean
    
    For i = 0 To UBound(vParamArray)
        If Not IsArray(vParamArray(i)) Then Exit Function
        ReDim Preserve strArr(i)
        strArr(i) = Join(vParamArray(i), ",")
    Next
    
    For i = 0 To UBound(vParamArray)
        For j = 0 To UBound(vParamArray(i))
            nVal = vParamArray(i)(j)
            If InStr(strResult, nVal) = 0 Then
                blnSame = True
                For k = 0 To UBound(strArr)
                    If InStr(strArr(k), nVal) = 0 Then
                        blnSame = False
                        Exit For
                    End If
                Next
                If blnSame Then strResult = strResult & "," & nVal
            End If
        Next
    Next
    strResult = Mid(strResult, 2)
    GetSameElement = strResult
End Function

Answer 1

Option Explicit
Option Base 0Private Sub Command1_Click()
    Dim a, b, c, d, e, a1
    Dim lSize&, arr&(), i&
     
    a = Array(0, 1, 5)
    b = Array(2, 4, 5, 9)
    c = Array(3, 5, 6)
    d = Array(1, 9, 2, 5, 8)
    e = Array(7, 5, 9, 2, 4)
    
    Debug.Print "a,b,c 交集"
    a1 = Array(0, 1, 2)
    GetUnionArray arr, lSize, a1, a, b, c, d, e
    
    For i = 0 To lSize
        Debug.Print arr(i)
    Next
    
    Debug.Print "b,d,e交集"
    a1 = Array(1, 3, 4)
    GetUnionArray arr, lSize, a1, a, b, c, d, e
    
    For i = 0 To lSize
        Debug.Print arr(i)
    Next
   
End SubPrivate Sub GetUnionArray(arrOut() As Long, lSize As Long, arrParam As Variant, ParamArray lParams())
    Dim lMergeSize As Long, lParamSize As Long
    Dim i As Long, j As Long, lCount As Long, lTmp As Long, lTotal As Long
    Dim arrMerge() As Long
    
    lMergeSize = UBound(arrParam)
    lParamSize = UBound(lParams)
    
    ' 合并指定数组
    For i = 0 To lMergeSize
        lSize = UBound(lParams(arrParam(i)))
        lCount = lCount + lSize + IIf(i = 0, 0, 1)
        ReDim Preserve arrMerge(lCount)
        For j = 0 To lSize
            arrMerge(lCount - lSize + j) = lParams(arrParam(i))(j)
        Next
    Next    ' 对合并后数组排序
    QuickSort arrMerge, 0, lCount
    
    ' 如果排序后相同的数值个数>=输入数组数,则为交集
    lSize = -1: lTotal = 1
    lTmp = arrMerge(0)
    For i = 1 To lCount
        If arrMerge(i) = lTmp Then
            lTotal = lTotal + 1
            If lTotal > lMergeSize And i = lCount Then
                lSize = lSize + 1
                ReDim Preserve arrOut(lSize)
                arrOut(lSize) = lTmp
            End If
        Else
            If lTotal > lMergeSize Then
                lSize = lSize + 1
                ReDim Preserve arrOut(lSize)
                arrOut(lSize) = lTmp
            End If
            lTotal = 1
            lTmp = arrMerge(i)
        End If
    Next
End Sub
Private Sub QuickSort(ByRef arr() As Long, l As Long, R As Long)
    Dim i As Long, j As Long, a As Long
    Dim TmpX As Long, TmpA As Long
    i = l: j = R: TmpX = arr((l + R) / 2)
    While (i <= j)
        While (arr(i) < TmpX And i < R)
            i = i + 1
        Wend
        While (TmpX < arr(j) And j > l)
            j = j - 1
        Wend
        If (i <= j) Then
            TmpA = arr(i)
            arr(i) = arr(j)
            arr(j) = TmpA
            i = i + 1: j = j - 1
        End If
    Wend
    If (l < j) Then Call QuickSort(arr, l, j)
    If (i < R) Then Call QuickSort(arr, i, R)
End Sub

Answer 2

Sub Main()
    Dim vParam
    Dim arr0, arr1, arr2, arr3, arr4
    
    arr0 = Array(1, 2, 3, 4, 5)
    arr1 = Array(1, 2, 9)
    arr2 = Array(1, 2, 10)
    arr3 = Array(1, 2, 5, 6)
    arr4 = Array(1, 2, 4, 7, 8)
    
    vParam = Array(arr0, arr2, arr3)
    Debug.Print GetSameElement(vParam)
End SubFunction GetSameElement(vParamArray As Variant) As String
    Dim strArr() As String
    Dim i As Long, j As Long, k As Long
    Dim strResult As String
    Dim nVal As Long
    Dim blnSame As Boolean
    
    If Not IsArray(vParamArray) Then Exit Function
    For i = 0 To UBound(vParamArray)
        If Not IsArray(vParamArray(i)) Then Exit Function
        ReDim Preserve strArr(i)
        strArr(i) = Join(vParamArray(i), ",")
    Next
    
    For i = 0 To UBound(vParamArray)
        For j = 0 To UBound(vParamArray(i))
            nVal = vParamArray(i)(j)
            If InStr(strResult, nVal) = 0 Then
                blnSame = True
                For k = 0 To UBound(strArr)
                    If InStr(strArr(k), nVal) = 0 Then
                        blnSame = False
                        Exit For
                    End If
                Next
                If blnSame Then strResult = strResult & "," & nVal
            End If
        Next
    Next
    strResult = Mid(strResult, 2)
    GetSameElement = strResult
End Function

Answer 3

假如我用一个字符串dis="arr0,arr2,arr3"
这样怎么也调不通
vparam=split(dis,",")
Debug.Print GetSameElement(vParam)

Answer 4

为什么一定要用字符串呢？VB不能根据字符串名称来得到数组内容，你就用Array对象来动态生成变量数组或者使用paramarray参数，如果一定要使用字符串名称，则需要使用类对象，然后结合scriptcontrol来完成。

Answer 5

比如：Private Sub Command1_Click()
    Dim strScript As String
    
    strScript = "Dim vParam" & vbCrLf
    strScript = strScript & "Dim arr0, arr1, arr2, arr3, arr4" & vbCrLf
    
    strScript = strScript & "arr0 = Array(1, 2, 3, 4, 5)" & vbCrLf
    strScript = strScript & "arr1 = Array(1, 2, 9)" & vbCrLf
    strScript = strScript & "arr2 = Array(1, 2, 10)" & vbCrLf
    strScript = strScript & "arr3 = Array(1, 2, 5, 6)" & vbCrLf
    strScript = strScript & "arr4 = Array(1, 2, 4, 7, 8)" & vbCrLf
    Me.ScriptControl1.AddCode strScript
    
    Dim strParam As String
    strParam = "frmTest.GetSameElement(arr0,arr1,arr2)" '参数用字符串拼接而成
    Debug.Print Me.ScriptControl1.Eval(strParam)
End SubPrivate Sub Form_Load()
    Me.ScriptControl1.AddObject "frmTest", Me
End SubPrivate Sub Form_Unload(Cancel As Integer)
    Me.ScriptControl1.Reset
End SubPublic Sub test()
    MsgBox "test"
    
End SubPublic Function GetSameElement(ParamArray vParamArray()) As String
    Dim strArr() As String
    Dim i As Long, j As Long, k As Long
    Dim strResult As String
    Dim nVal As Long
    Dim blnSame As Boolean
    
    For i = 0 To UBound(vParamArray)
        If Not IsArray(vParamArray(i)) Then Exit Function
        ReDim Preserve strArr(i)
        strArr(i) = Join(vParamArray(i), ",")
    Next
    
    For i = 0 To UBound(vParamArray)
        For j = 0 To UBound(vParamArray(i))
            nVal = vParamArray(i)(j)
            If InStr(strResult, nVal) = 0 Then
                blnSame = True
                For k = 0 To UBound(strArr)
                    If InStr(strArr(k), nVal) = 0 Then
                        blnSame = False
                        Exit For
                    End If
                Next
                If blnSame Then strResult = strResult & "," & nVal
            End If
        Next
    Next
    strResult = Mid(strResult, 2)
    GetSameElement = strResult
End Function

Answer 6

不是我向用字符串来解决，而实际情况要用到，上面也解释了
假如我有五个数组arr0,arr1,arr2,arr3,arr4,我把这5个数组名称放入一个list,任意选取他们的组合，赋值给函数怎么解决呢，代码如下
ption Explicit
Dim arr0, arr1, arr2, arr3, arr4, arr5, arr6
Dim vParam
Dim DistrictJoin As StringPrivate Sub List1_Click()
    Dim i As Long
    Dim n As Long
    n = List1.ListCount
    DistrictJoin = ""
    For i = 0 To n - 1
        If List1.Selected(i) = True Then
            DistrictJoin = DistrictJoin & "," & "arr" & i
            Combo1(i).Enabled = True
        Else
            Combo1(i).Enabled = False
        End If
    Next
    DistrictJoin = Trim(Mid(DistrictJoin, 2))
End SubPrivate Sub Command1_Click()
    Dim arr() As String
    Dim Temparr As String
    Dim i As Long
    Dim n As Long
    List2.Clear
    MsgBox DistrictJoin
 vParam = Split(DistrictJoin, ",")
    arr = Split(GetSameElement(vParam), ",")
    n = UBound(arr)
        For i = 0 To n
            List2.AddItem arr(i)
        Next
End Sub
Function GetSameElement(vParamArray As Variant) As String
    Dim strArr() As String
    Dim i As Long, j As Long, k As Long
    Dim strResult As String
    Dim nVal As String
    Dim blnSame As Boolean
    
    If Not IsArray(vParamArray) Then Exit Function
    For i = 0 To UBound(vParamArray)
        If Not IsArray(vParamArray(i)) Then Exit Function
        ReDim Preserve strArr(i)
        strArr(i) = Join(vParamArray(i), ",")
    Next
    
    For i = 0 To UBound(vParamArray)
        For j = 0 To UBound(vParamArray(i))
            nVal = vParamArray(i)(j)
            If InStr(strResult, nVal) = 0 Then
                blnSame = True
                For k = 0 To UBound(strArr)
                    If InStr(strArr(k), nVal) = 0 Then
                        blnSame = False
                        Exit For
                    End If
                Next
                If blnSame Then strResult = strResult & "," & nVal
            End If
        Next
    Next
    strResult = Mid(strResult, 2)
    GetSameElement = strResult
End Function

Answer 7

唉，你不会改一下。Private Sub Command1_Click()
    Dim i As Long
    Dim strParam As String
    
    For i = 0 To Me.List1.ListCount - 1
        If Me.List1.Selected(i) Then
            strParam = strParam & "," & Me.List1.List(i)
        End If
    Next
    strParam = Mid(strParam, 2)
    If Len(strParam) > 0 Then
        strParam = "frmTest.GetSameElement(" & strParam & ")" '参数用字符串拼接而成
        MsgBox Me.ScriptControl1.Eval(strParam)
    End If
End SubPrivate Sub Form_Load()
    Dim strScript As String
    
    strScript = "Dim vParam" & vbCrLf
    strScript = strScript & "Dim arr0, arr1, arr2, arr3, arr4" & vbCrLf
    
    strScript = strScript & "arr0 = Array(1, 2, 3, 4, 5)" & vbCrLf
    strScript = strScript & "arr1 = Array(1, 2, 9)" & vbCrLf
    strScript = strScript & "arr2 = Array(1, 2, 10)" & vbCrLf
    strScript = strScript & "arr3 = Array(1, 2, 5, 6)" & vbCrLf
    strScript = strScript & "arr4 = Array(1, 2, 4, 7, 8)" & vbCrLf
    
    Me.ScriptControl1.AddCode strScript
    
    Me.List1.AddItem "arr0"
    Me.List1.AddItem "arr1"
    Me.List1.AddItem "arr2"
    Me.List1.AddItem "arr3"
    Me.List1.AddItem "arr4"
    'Me.List1.MultiSelect的属性必须为1或2
    Me.ScriptControl1.AddObject "frmTest", Me
End SubPrivate Sub Form_Unload(Cancel As Integer)
    Me.ScriptControl1.Reset
End SubPublic Function GetSameElement(ParamArray vParamArray()) As String
    Dim strArr() As String
    Dim i As Long, j As Long, k As Long
    Dim strResult As String
    Dim nVal As Long
    Dim blnSame As Boolean
    
    For i = 0 To UBound(vParamArray)
        If Not IsArray(vParamArray(i)) Then Exit Function
        ReDim Preserve strArr(i)
        strArr(i) = Join(vParamArray(i), ",")
    Next
    
    For i = 0 To UBound(vParamArray)
        For j = 0 To UBound(vParamArray(i))
            nVal = vParamArray(i)(j)
            If InStr(strResult, nVal) = 0 Then
                blnSame = True
                For k = 0 To UBound(strArr)
                    If InStr(strArr(k), nVal) = 0 Then
                        blnSame = False
                        Exit For
                    End If
                Next
                If blnSame Then strResult = strResult & "," & nVal
            End If
        Next
    Next
    strResult = Mid(strResult, 2)
    GetSameElement = strResult
End Function

Answer 8

添加部件“Microsoft Script Control 1.0”，然后在Form上放置一个控件。

Answer 9

不好意思，我对这个控件不怎么理解，没完全看懂你写的这个控件代码，能不能在你代码里不赋值呢，arr0,arr1,arr2等我已经在另外过程中赋值好了，