Excel代码问题，非常感谢！

quqiyuan

代码如下。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$HH$1" Then
        arr = [hp182:hp821]
        brr = [hq182:hq821]
        Set d = CreateObject("scripting.dictionary")
        Set dic = CreateObject("scripting.dictionary")
        For i = 1 To UBound(arr)
            If arr(i, 1) <> Empty Then
                If Not d.exists(arr(i, 1)) Then d(arr(i, 1)) = 1 Else If arr(i, 1) <> arr(i - 1, 1) Then d(arr(i, 1)) = d(arr(i, 1)) + 1
            End If
            If brr(i, 1) <> Empty Then
                If Not dic.exists(brr(i, 1)) Then dic(brr(i, 1)) = 1 Else If brr(i, 1) <> brr(i - 1, 1) Then dic(brr(i, 1)) = dic(brr(i, 1)) + 1
            End If
        Next
        key = d.keys
        k = dic.keys
        Item = d.items
        it = dic.items
        key = sort_s(key)
        k = sort_s(k)
        ReDim crr(0 To UBound(key))
        ReDim drr(0 To UBound(k))
        For i = 0 To UBound(key)
            crr(i) = d(key(i))
        Next
        For i = 0 To UBound(k)
            drr(i) = dic(k(i))
        Next
        [he639].CurrentRegion.ClearContents
        Cells(639 - d.Count + 1, "he").Resize(d.Count) = Application.Transpose(key)
        Cells(639 - d.Count + 1, "hf").Resize(d.Count) = Application.Transpose(crr)
        Cells(639 - dic.Count + 1, "hg").Resize(dic.Count) = Application.Transpose(k)
        Cells(639 - dic.Count + 1, "hh").Resize(dic.Count) = Application.Transpose(drr)
        Set d = Nothing
        Set dic = Nothing
        Beep
    End If
End Sub

Function sort_s(key)
    For i = 0 To UBound(key) - 1
        For j = i + 1 To UBound(key)
            If key(i) > key(j) Then
                t = key(i)
                key(i) = key(j)
                key(j) = t
            End If
        Next
    Next
    sort_s = key
End Function

LSYYLW

quqiyuan 发表于 2024-7-21 23:14
代码如下。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$HH$1" ...

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