Excel代码问题，非常感谢！

LSYYLW

2024-11-21---.zip (14.98 KB, 下载次数: 4)

2024-11-21 16:10 上传

点击文件名下载附件

titi012

参与一下。。。。。。

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Address = "$FX$1" Then
        arr = [fp210].CurrentRegion
        Set d = CreateObject("scripting.dictionary")
        ReDim brr(1 To 1000, 1 To 2)
        For j = 1 To 2
            n = 0: ReDim brr(1 To 1000, 1 To 2)
            For i = 1 To UBound(arr)
                If arr(i, j) <> "" Then
                    If Not d.exists(arr(i, j)) Then
                        n = n + 1: d(arr(i, j)) = n: brr(n, 1) = arr(i, j): brr(n, 2) = 1
                    Else
                        brr(d(arr(i, j)), 2) = brr(d(arr(i, j)), 2) + 1
                    End If
                End If
            Next
            For i = 1 To n - 1
                For k = i + 1 To n
                    If brr(i, 1) > brr(k, 1) Then
                        t = brr(i, 1)
                        brr(i, 1) = brr(k, 1)
                        brr(k, 1) = t
                        t = brr(i, 2)
                        brr(i, 2) = brr(k, 2)
                        brr(k, 2) = t
                    End If
                Next
            Next
            If j = 1 Then
                [fx2:fy100].ClearContents
                Cells(100 - n + 1, "fx").Resize(n, 2) = brr
            Else
                [fz2:ga100].ClearContents
                Cells(100 - n + 1, "fz").Resize(n, 2) = brr
            End If
            d.RemoveAll
        Next
        Set d = Nothing
        Beep
    End If
    Application.EnableEvents = True
End Sub
   

LSYYLW

titi012 发表于 2024-11-21 17:09
参与一下。。。。。。

非常感谢老师！

LSYYLW

quqiyuan 发表于 2024-11-21 18:10
代码如下。。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents  ...

万分的感谢老师，代码非常非常好用。