帮我写一个excel的vba脚本吧

这个之前回答过了吧！！这里利用了一个辅助的工作表与SQL。完整代码如下

Sub 数据匹配统计()
    Dim xSh As Worksheet, ySh As Worksheet
    Dim xRan As Range, yRan As Range
    Dim arr
    Dim conn As Object
     
    If ActiveWorkbook.Name <> ThisWorkbook.Name Then
        MsgBox "此程序只能用于“" & ThisWorkbook.Name & "”文件"
        Exit Sub
    End If
         
    Set xSh = ThisWorkbook.Worksheets("辅助")
     
    xSh.Range("A:B").ClearContents
    xSh.Range("A1:B1") = Array("数据1", "值1")
     
    Set xRan = xSh.Range("A2")
     
    Set ySh = ThisWorkbook.Worksheets("数据")
         
    Set yRan = ySh.Range("A2")
     
    Do While yRan <> ""
     
        arr = Split(yRan, " ")
        xRan.Resize(UBound(arr) + 1, 1) = yRan
        xRan.Offset(0, 1).Resize(UBound(arr) + 1, 1) = WorksheetFunction.Transpose(arr)
     
        Set xRan = xRan.Offset(UBound(arr) + 1, 0)
        Set yRan = yRan.Offset(1, 0)
    Loop
 
 
    xSh.Range("D:E").ClearContents
    xSh.Range("D1:E1") = Array("数据2", "值2")
     
    Set xRan = xSh.Range("D2")
     
    Set ySh = ThisWorkbook.Worksheets("数据")
         
    Set yRan = ySh.Range("B2")
     
    Do While yRan <> ""
     
        arr = Split(yRan, " ")
        xRan.Resize(UBound(arr) + 1, 1) = yRan
        xRan.Offset(0, 1).Resize(UBound(arr) + 1, 1) = WorksheetFunction.Transpose(arr)
     
        Set xRan = xRan.Offset(UBound(arr) + 1, 0)
        Set yRan = yRan.Offset(1, 0)
    Loop
 
 
    Set conn = CreateObject("ADODB.Connection")
     
    Select Case Application.Version * 1
    Case Is <= 11
        conn.ConnectionString = "Provider=Microsoft.Jet.Oledb.4.0;" & _
                                "Extended Properties=Excel 8.0;" & _
                                "Data Source=" & ThisWorkbook.Path & "\" & ThisWorkbook.Name
    Case Is >= 12
        conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                                "Extended Properties=Excel 8.0;" & _
                                "Data Source=" & ThisWorkbook.Path & "\" & ThisWorkbook.Name
        strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathStr & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
    End Select
     
    conn.Open
     
    sSql = "Select f.jg From [数据$B:B] e LEFT JOIN (Select c.sj2c As sj2f ,Count(*) As jg From (Select a.数据1 As sj1c ,b.数据2 As sj2c ,Count(*) As tj1 From [辅助$A:B] a , [辅助$D:E] b Where a.值1 = b.值2 Group By a.数据1 ,b.数据2) c,(Select 数据1 As sj1d,Count(*) As tj2 From [辅助$A:B] Group By 数据1) d Where c.sj1c = d.sj1d And c.tj1 = d.tj2 Group By c.sj2c) f On e.数据2 = f.sj2f"
    ySh.Range("C:C").ClearContents
    ySh.Range("C1") = "包含"
    ySh.Range("C2").CopyFromRecordset conn.Execute(sSql)
     
    conn.Close
    Set conn = Nothing
 
End Sub

附上文件

数据一都是五个数据？ 数据二都是升序？
试试
Sub 求包含()
Dim arr3()
arr1 = Range([a2], Cells(Rows.Count, 1).End(xlUp))
arr2 = Range([b2], Cells(Rows.Count, 2).End(xlUp))
For i = 1 To UBound(arr1)
arr = Split(arr1(i, 1), " ")
arr1(i, 1) = ""
ReDim arr3(1 To UBound(arr) + 1)
For Each a In arr
n = n + 1
arr3(n) = Val(a)
Next
n = 0
a = Application.Max(arr3)
For j = 1 To UBound(arr3)

arr1(i, 1) = arr1(i, 1) & " " & WorksheetFunction.Small(arr3, j)
Next
arr1(i, 1) = Right(arr1(i, 1), Len(arr1(i, 1)) - 1)

Next

For i = 1 To UBound(arr2)
For j = 1 To UBound(arr1)
arr4 = Split(arr1(j, 1))

If arr2(i, 1) Like "*" & arr4(0) & "*" & arr4(1) & "*" & arr4(2) & "*" & arr4(3) & "*" & arr4(4) & "*" Then k = k + 1
Next
If k > 0 Then Cells(i + 1, 3) = k Else Cells(i + 1, 3) = ""
k = 0
Next
End Sub