Excel代码问题，非常感谢！

LSYYLW

quqiyuan 发表于 2024-10-2 11:39
代码如下。。。

Private Sub Worksheet_Change(ByVal Target As Range)

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

quqiyuan

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

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

quqiyuan

代码如下。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$GU$1" Or Target.Address = "$GY$1" Then
    Application.EnableEvents = False
    arr = [fh3:gu7]
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    ReDim crr(1 To UBound(arr), 1 To 8)
    s = [gu1]
    ss = [gy1]
    If ss = 1 Then
        brr = arr
    ElseIf ss = 2 Then
        For i = 1 To UBound(arr)
            For j = 2 To UBound(arr, 2)
                brr(i, j - 1) = arr(i, j)
            Next
            brr(i, j - 1) = arr(i, 1)
        Next
    ElseIf ss = s Then
        For i = 1 To UBound(arr)
            For j = s To UBound(arr, 2)
                brr(i, j - ss + 1) = arr(i, j)
            Next
            For k = 1 To ss - 1
                brr(i, j - k) = arr(i, k)
            Next
        Next
    End If
    For i = 1 To UBound(brr)
        For j = 1 To UBound(brr, 2) Step s
            Sum = 0
            For k = 0 To s - 1
                If brr(i, j + k) <> 0 Then Sum = Sum + 1
            Next
            crr(i, Int(j / s) + 1) = Sum
        Next
    Next
    [gy3:hf7] = Empty
    [gy3:hf7] = crr
    Application.EnableEvents = True
    Beep
    End If
End Sub

LSYYLW

2024-10-4-.zip (12.5 KB, 下载次数: 2)

2024-10-4 20:04 上传

点击文件名下载附件

LSYYLW

quqiyuan 发表于 2024-10-4 17:53
代码如下。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$GU$1" ...

非常感谢老师，怪我没有给老师演示全面，我又重新编写了条件说明，麻烦老师您再帮我看一下14楼的附件，帮我解决一下，拜托您了！

quqiyuan

LSYYLW 发表于 2024-10-4 20:07
非常感谢老师，怪我没有给老师演示全面，我又重新编写了条件说明，麻烦老师您再帮我看一下14楼的附件，帮 ...

quqiyuan

代码如下。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$GU$1" Or Target.Address = "$GY$1" Then
    Application.EnableEvents = False
    arr = [fh3:gu7]
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    ReDim crr(1 To UBound(arr), 1 To 8)
    s = [gu1]
    ss = [gy1]
    If IsNumeric(s) And IsNumeric(ss) And s >= ss Then
        For i = 1 To UBound(arr)
            For j = ss To UBound(arr, 2)
                brr(i, j - ss + 1) = arr(i, j)
            Next
            For k = 1 To ss - 1
                brr(i, j - k) = arr(i, k)
            Next
        Next
        For i = 1 To UBound(brr)
            For j = 1 To UBound(brr, 2) Step s
                Sum = 0
                For k = 0 To s - 1
                    If brr(i, j + k) <> 0 Then Sum = Sum + 1
                Next
                crr(i, Int(j / s) + 1) = Sum
            Next
        Next
    End If
    [gy3:hf7] = Empty
    [gy3:hf7] = crr
    Application.EnableEvents = True
    Beep
    End If
End Sub

LSYYLW

quqiyuan 发表于 2024-10-4 21:05
代码如下。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$GU$1" ...

再次感谢老师，代码非常好用，完美解决了，让您受累了。