Excel代码问题，非常感谢！

quqiyuan

代码如下。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Address = "$L$1" Then
        arr = [e3:e102]
        brr = [h11:h15]
        ReDim crr(1 To UBound(arr), 1 To 2)
        Set d = CreateObject("scripting.dictionary")
        For i = 1 To UBound(brr)
            s = brr(i, 1)
            d(s) = i
        Next
        For i = 1 To UBound(arr)
            s = arr(i, 1)
            If i = 1 Then
                If d.exists(s) Then
                    crr(i, 1) = 1
                    crr(i, 2) = 0
                Else
                    crr(i, 2) = 1
                    crr(i, 1) = 0
                End If
            Else
                If d.exists(s) Then
                    crr(i, 1) = crr(i - 1, 1) + 1
                    crr(i, 2) = 0
                Else
                    crr(i, 2) = crr(i - 1, 2) + 1
                    crr(i, 1) = 0
                End If
            End If
        Next
        For j = 1 To 2
            For i = UBound(crr) To 2 Step -1
                If crr(i, j) > crr(i - 1, j) And crr(i - 1, j) <> 0 Then
                    crr(i - 1, j) = crr(i, j)
                End If
            Next
        Next
        [l3].Resize(UBound(crr), 2) = crr
        Set d = Nothing
    End If
    Application.EnableEvents = True
End Sub

LSYYLW

2024-10-29---.zip (4.35 KB, 下载次数: 2)

2024-10-29 12:25 上传

点击文件名下载附件

LSYYLW

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

万分的感谢老师，代码非常好用。抱歉老师，今天还得麻烦您一下，您有时间再帮我看一下12楼附件里的问题，帮我解决一下，拜托了！

quqiyuan

供你参考。。。

quqiyuan

代码如下。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Address = "$T$1" Then
        arr = [e13:e112]
        brr = [p13:p112]
        ReDim crr(1 To UBound(arr), 1 To 2)
        For i = 1 To UBound(arr)
            If i = 1 Then
                If brr(i, 1) = 0 And arr(i, 1) = 0 Then
                    crr(i, 1) = 1
                    crr(i, 2) = 0
                Else
                    crr(i, 2) = 1
                    crr(i, 1) = 0
                End If
            Else
                If brr(i, 1) = 0 And arr(i, 1) = 0 Then
                    crr(i, 1) = crr(i - 1, 1) + 1
                    crr(i, 2) = 0
                Else
                    crr(i, 2) = crr(i - 1, 2) + 1
                    crr(i, 1) = 0
                End If
            End If
        Next
        For j = 1 To 2
            For i = UBound(crr) To 2 Step -1
                If crr(i, j) > crr(i - 1, j) And crr(i - 1, j) <> 0 Then
                    crr(i - 1, j) = crr(i, j)
                End If
            Next
        Next
        [t13].Resize(UBound(crr), 2) = crr
    End If
    Application.EnableEvents = True
End Sub

LSYYLW

quqiyuan 发表于 2024-10-29 14:32
代码如下。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents =  ...

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

LSYYLW

2024-10-30.zip (16.16 KB, 下载次数: 2)

2024-10-30 11:07 上传

点击文件名下载附件

LSYYLW

quqiyuan 发表于 2024-10-29 14:32
代码如下。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents =  ...

老师您好：又来麻烦您了，您有时间帮我看一下17楼附件里的问题，帮我解决一下，拜托了！

quqiyuan

LSYYLW 发表于 2024-10-30 11:09
老师您好：又来麻烦您了，您有时间帮我看一下17楼附件里的问题，帮我解决一下，拜托了！

供你参考。。。

quqiyuan

代码如下。。。
   
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Address = "$BF$1" Then
        arr = [bf182:bf821]
        brr = [bi1:bm1]
        ReDim crr(1 To 10000, 1 To UBound(brr, 2))
        For j = 1 To UBound(brr, 2)
            x = brr(1, j): n = 0
            For i = UBound(arr) - x + 1 To 1 Step -x
                n = n + 1
                crr(n, j) = arr(i, 1)
            Next
            y = Application.Max(y, n)
        Next
        ReDim drr(1 To y, 1 To UBound(brr, 2))
        For i = 1 To UBound(brr, 2)
            n = 0
            For j = y To 1 Step -1
                n = n + 1
                drr(n, i) = crr(j, i)
            Next
        Next
        Cells(642 - y + 1, "bi").Resize(y, UBound(brr, 2)) = drr
    End If
    Application.EnableEvents = True
End Sub