彩票组选分布图制作显示有错误请大神帮看下代码

freeback

哪位大神帮我看看，下面代码问题在哪里，当输入的号码是大于6以上的对子时显示错误，但是小于6以下的对子时有时正确的，遇到豹子666也会显示错误，上标号码不显示出来
Sub pszx()  
    Dim brr()
    Dim crr()
    Dim drr()
    Dim zrr()
    r = Sheet1.Cells(Rows.Count, 3).End(xlUp).Row
    arr = Sheet1.Range("C4:E" & r)
    ys = Sheet1.Range("F3:O3")
    For i = 1 To UBound(arr)
        For j = 1 To UBound(arr, 2)
            'a = arr(i, j) Mod 10
            a = arr(i, j)
            ReDim Preserve drr(1 To UBound(arr), 1 To 3)
            drr(i, j) = a
            ReDim Preserve brr(1 To UBound(arr), 1 To 10)
            For c = 1 To UBound(ys, 2)
                If ys(1, c) = a Then brr(i, c) = a
            Next
        Next
    Next
    For s = 1 To UBound(drr)
        Set d = CreateObject("scripting.dictionary")
        For k = 1 To UBound(drr, 2)
            d(drr(s, k)) = d(drr(s, k)) + 1
        Next
        ReDim Preserve crr(1 To UBound(drr), 1 To 10)
            For ii = 0 To d.Count
                If d.Item(ii) > 1 Then
                    crr(s, ii + 1) = d.Item(ii)
                End If
            Next
        Set d = Nothing
    Next


    ReDim Preserve zrr(1 To UBound(brr), 1 To 10)
    For i = 1 To UBound(brr)
        For j = 1 To UBound(crr, 2)
            If crr(i, j) = "" Then
                zrr(i, j) = brr(i, j)
            Else
                zrr(i, j) = brr(i, j) & " " & crr(i, j)
            End If
        Next
    Next
    Application.ScreenUpdating = False
    Sheet1.Range("F4:O" & r).ClearContents   
    Sheet1.[F4].Resize(UBound(zrr), 10) = zrr
    For Each Rng In Sheet1.Range("F4:O" & r)  
        If Len(Rng) = 3 Then
            With Rng.Characters(Start:=2, Length:=2).Font
                .Name = "宋体"
                .FontStyle = "加粗"
                .Size = 18
                .Color = vbRed
                .Superscript = True
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub

鄂龙蒙

组选分布有错误.rar (28.74 KB, 下载次数: 24)

2023-4-22 10:17 上传

点击文件名下载附件

02761752696

将   For ii = 0 To d.Coun   改成  For ii = 0 To 9  试试

freeback

鄂龙蒙 发表于 2023-4-22 10:17

非常感谢，你将代码进行简化了，操作更方便，感谢感谢

freeback

02761752696 发表于 2023-4-22 11:16
将   For ii = 0 To d.Coun   改成  For ii = 0 To 9  试试

这个操作我试过了

freeback

但是哪位大神能帮我看下我发的这个代码错误在哪里呢？求解

不知道为什么

freeback 发表于 2023-4-23 00:26
但是哪位大神能帮我看下我发的这个代码错误在哪里呢？求解

如图  参考。。。。。。。。。。

freeback

不知道为什么 发表于 2023-4-23 07:23
如图  参考。。。。。。。。。。

哦哦，明白了，感谢提醒，指点