能力有限，真搞不定，求救！

jx928867128

这是我手抄版主帮忙写的代码，分享给有同样需求教务同行



Sub 按钮8_Click()
    Sum = 0
    Sheets(2).[a1].CurrentRegion.Offset(1, 1).ClearContents
lxl:
    Sum = Sum + 1
    If Sum = 999 Then
        MsgBox "GAME OVER"
        Exit Sub
    End If
    Set d = CreateObject("scripting.dictionary")
    Set dw = CreateObject("scripting.dictionary")
    Set dd = CreateObject("scripting.dictionary")
    arr = Sheets(1).[a1].CurrentRegion
    For j = 2 To UBound(arr)
        Set dd(arr(j, 1)) = CreateObject("scripting.dictionary")
        For i = 2 To UBound(arr, 2)
            If Not d.exists(arr(j, i)) And Len(arr(j, i)) > 0 Then
                Set d(arr(j, i)) = CreateObject("scripting.dictionary")
            End If
            d(arr(j, i))(arr(j, 1)) = -1
            dd(arr(j, 1))(arr(j, i)) = 0
        Next i
    Next j
    arr = Sheets(2).[a1].CurrentRegion
    For i = 2 To UBound(arr, 2)
        For j = 2 To UBound(arr)
            For w = -1 To UBound(arr, 2)
                dw.RemoveAll
                For x = 1 To d.Count
                    dw(x) = ""
                Next x
                For xx = 1 To d.Count
                    y = WorksheetFunction.RandBetween(0, dw.Count - 1)
                    x = dw.keys()(y)
                    dw.Remove x
                    k = d.keys()(x - 1)
                    If d(k).exists(arr(j, 1)) Then
                        If d(k)(arr(j, 1)) = w Then
                            zz = 0
                            For Each kk In d(k).items
                                If kk = i Then zz = 1
                            Next
                            If zz = 0 Then
                                arr(j, i) = k
                                 d(k)(arr(j, 1)) = i
                                 GoTo 11
                            End If
                        End If
                    End If
                Next xx
            Next w
11:
        Next j
    Next i
    For j = 2 To UBound(arr)
       For i = 2 To UBound(arr, 2)
           If Len(arr(j, i)) = 0 Then
               For n = 0 To dd(arr(j, 1)).Count - 1
                   k = dd(arr(j, 1)).keys()(n)
                   If k <> arr(j, i - 1) Then
                       If i < UBound(arr, 2) Then
                           If k <> arr(j, i + 1) Then
                               For w = 2 To UBound(arr)
                                   If w <> j Then
                                       If k = arr(w, i) Then
                                           For Z = 2 To UBound(arr, 2)
                                               For y = 2 To UBound(arr)
                                                   If arr(y, Z) = k Then GoTo 12
                                                   If arr(w, Z) = arr(y, i) Then GoTo 12
                                               Next y
                                               arr(j, i) = k
                                               tm = arr(w, Z)
                                               arr(w, Z) = k
                                               arr(w, i) = tm
                                               GoTo 13
12:
                                           Next Z
                                       End If
                                   End If
                               Next w
                           End If
                       End If
                   End If
               
               Next n
13:
           End If
       Next i
    Next j
    For j = 2 To UBound(arr)
        For i = 2 To UBound(arr, 2)
            If Len(arr(j, i)) = 0 Then
                GoTo lxl:
            End If
        Next i
    Next j
   
   
    For j = 2 To UBound(arr)
        For i = 4 To UBound(arr, 2) - 1
            If arr(j, i - 1) = arr(j, i - 2) Then
                If arr(j, i) = arr(j, i - 1) Or arr(j, i + 1) = arr(j, i - 1) Then
                    GoTo lxl:
                End If
            End If
        Next i
    Next j
   
   
    For j = 2 To UBound(arr)
        For i = 2 To UBound(arr, 2) - 3
            If arr(j, i + 2) = arr(j, i + 3) Then
                If arr(j, i) = arr(j, i + 2) Or arr(j, i + 1) = arr(j, i + 2) Then
                    GoTo lxl:
                End If
            End If
        Next i
    Next j
    Sheets(2).[a1].CurrentRegion = arr
    MsgBox "数据提取完毕！"
End Sub

liulang0808

jx928867128 发表于 2024-6-19 09:08
谢谢版主的帮忙，我把您的代码抄了下，发现运行不了，应该是哪个地方抄错了，麻烦您帮忙修正下好吗

代码截图就在那里，很清楚的
看看if 是否有对应结束的end if，for是否有对应的next

jx928867128

liulang0808 发表于 2024-6-19 12:46
代码截图就在那里，很清楚的
看看if 是否有对应结束的end if，for是否有对应的next

感谢版主的再次回复，核对了好几次，改来改去已面目全非了，前看后忘再次感谢您的多次帮忙与中肯的回复

jx928867128

jx928867128 发表于 2024-6-19 13:45
感谢版主的再次回复，核对了好几次，改来改去已面目全非了，前看后忘再次感谢您的多次帮忙与中肯的回 ...

谢谢点评，我反复核对了，就是发现不了错的地方，这改那改现在改得什么错误的提示都有，眼睛都搞花了

jx928867128

jx928867128 发表于 2024-6-19 19:48
谢谢点评，我反复核对了，就是发现不了错的地方，这改那改现在改得什么错误的提示都有，眼睛都搞花了

版主早上好，您在我写的程序我昨晚测试了下， 发现数据更新后运行不出结果，麻烦您抽空帮我看看好吗

jx928867128

liulang0808 发表于 2024-6-19 12:46
代码截图就在那里，很清楚的
看看if 是否有对应结束的end if，for是否有对应的next

谢谢版主的再次指导，我再核对下

jx928867128

jx928867128 发表于 2024-6-20 06:09
版主早上好，您在我写的程序我昨晚测试了下， 发现数据更新后运行不出结果，麻烦您抽空帮我看看好吗

谢谢版主的帮忙，刚才再让年轻老师对了2次，他们说代码没有抄错，我这里抄的代码是用一楼附件中数据去跑，是可以跑出来正确的结果，如果换了25楼的数据，程序也会运行，运行完全出现这个提示，但没有结果，不知您方便用25楼的数据试跑下好吗

liulang0808

因为做了随机分配，有可能不出结果，但是目前测试了两次都出结果了。
不知道结果是否符合楼主的规范。
此贴不再回复，之前代码楼主参考着用吧

jx928867128

liulang0808 发表于 2024-6-20 16:26
因为做了随机分配，有可能不出结果，但是目前测试了两次都出结果了。
不知道结果是否符合楼主 ...

非常感谢您的再次回复，应该是代码我抄时不知道哪里出问题了，能力有限，是真的找不到哪里抄错了。

jx928867128

liulang0808老师写的监考程序.rar (29.39 KB, 下载次数: 9)

2024-6-21 13:24 上传

点击文件名下载附件

我手抄了版主帮我写的代码（版主的代码肯定是没问题），我用测试数据1和2无法得到结果（版主也测试过，可以得到结果），我也核对了近20次，也没有发现代码在哪里抄错了，有没有哪位好心人方便帮我看看哪里抄错了吗？