我菜鸟什么都不懂(不知什么时侯才学懂)，请神人在每句能详细解释，因我菜鸟什么都不懂。
Sub DataSplit()
    m = Sheet1.[a1].End(4).Row
    arr = Sheet1.[c1].Resize(m, 5)
    ReDim brr(2 To m, 1 To 11)
    For i = 2 To m
        For j = 1 To 5
            t = arr(i, j)
            brr(i, t) = t
        Next
    Next
    Sheet1.[h2].Resize(m - 1, 11) = brr
End Sub
Sub kagawa()
    Dim i&, j&, k&, h&, m&, n&, Ac&, r&, s$, t, cnt&
    tms = Timer
   
    m = 11: n = 8: Ac8 = (m, n)
    ReDim Combin8&(1 To Ac8, 1 To m)
    Call GetCombinArr(Combin8, m, n)
   
    Sheet1.Activate
    m = Sheet1.[a1].End(4).Row
    arr = Sheet1.[c1].Resize(m, 5)
'    Sheet2.Activate
    ReDim brr&(2 To m, 1 To 5)
    For i = 2 To m
        For j = 1 To 5
            brr(i, j) = arr(i, j)
        Next
    Next
   
    ReDim crr(1 To Ac8, 1 To m)
    For k = 1 To Ac8
        cnt = 0
        For i = 2 To m
            r = 0
            For j = 1 To 5
                r = r + Combin8(k, brr(i, j))
            Next
            If r = 5 Then crr(k, i) = i: cnt = cnt + 1
        Next
        crr(k, 1) = cnt
    Next
    With Sheet2
        .[a1].CurrentRegion.AutoFilter
        .[a1].CurrentRegion.Offset(1, 9) = ""
        .[k2].Resize(Ac8, m) = crr
        .Cells(1, 10) = "result"
        .Cells(1, 11) = "cnt"
        For i = 2 To m
            .Cells(1, i + 10) = "s" & i
        Next
    End With
   
    ReDim drr(1 To Ac8, 0 To 1)
    For i = 1 To Ac8
        drr(i, 1) = 1
    Next
   
    ReDim frr(2 To m) As Boolean
    Randomize
    h = m - 1
    k = 0
    Do
        cnt = 1
        For i = 1 To Ac8
            If drr(i, 1) > 0 Then
                r = 0
                For j = 2 To m
                    If Not frr(j) Then If crr(i, j) Then r = r + 1
                Next
                If r Then drr(i, 1) = r Else drr(i, 1) = ""
                If r = cnt Then s = s & "," & i Else If r > cnt Then cnt = r: s = i
            End If
        Next
        
        t = Split(s, ",")
        r = t(Int(Rnd * (UBound(t) + 1)))
        
        cnt = 0
        For j = 2 To m
            If Not frr(j) Then If crr(r, j) Then frr(j) = True: cnt = cnt + 1
        Next
        drr(r, 0) = cnt
        drr(r, 1) = ""
        h = h - cnt
        k = k + 1
    Loop While h
    With Sheet2
        .[j2].Resize(Ac8) = drr
        .[a1].AutoFilter Field:=10, Criteria1:="<>"
        .[i1].Resize(Ac8, 3).SpecialCells(xlCellTypeVisible).Copy
    End With
'    Sheet1.Activate
    Sheet1.[j1].CurrentRegion = ""
    Sheet1.[j1].PasteSpecial Paste:=xlPasteValues
   
    MsgBox Format(Timer - tms, "0.000s ") & k
End Sub
Sub GetCombinArr(arr&(), m&, n&)
    Dim i&, j&, l&
    ReDim a&(1 To n)
    a(1) = 0: a(n) = m: j = 1
    For i = 1 To (m, n)
        If a(n) = m Then
            a(j) = a(j) + 1
            If a(j) < m - n + j Then
                For j = j To n - 1
                    a(j + 1) = a(j) + 1
                Next
            End If
            j = j - 1
        Else
            a(n) = a(n) + 1
        End If
        For l = 1 To n
            arr(i, a(l)) = 1
        Next
    Next
End Sub
模块2--------------------------------------------------------模块2
Sub Macro2()
    Range("I1:K166").SpecialCells(xlCellTypeVisible).Copy
    Selection.PasteSpecial Paste:=xlPasteValues
   
End Sub
Sub Macro3()
'
' Macro3 Macro
' Macro recorded 2013/5/22 by NWP18
'

'
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
End Sub

[ 本帖最后由 warosng 于 2013-10-6 20:28 编辑 ]