Excel代码问题，非常感谢！

LSYYLW

2024-6-7.zip (81.79 KB, 下载次数: 1)

2024-6-5 21:53 上传

点击文件名下载附件

LSYYLW

longwin 发表于 2024-6-5 20:39
好了。请看一下是否时你想要的方式：

老师您好：又来麻烦您了，您有时间帮我看一下10楼附件里有颜色单元格里的文字，帮我解决一下，拜托了！

longwin

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
    arr = Sheet11.Range("CI1216:FJ1217")
    brr = Sheet11.Range("CI3:FJ1218")
    ReDim crr(1 To UBound(brr, 1), 1 To UBound(brr, 2))
    For c = 1 To UBound(brr, 2)
        s1 = arr(1, c)
        s2 = arr(2, c)
        m = UBound(crr, 1)
        For i = UBound(brr, 1) To 3 Step -1
            If brr(i - 1, c) = s2 And brr(i - 2, c) = s1 Then
                crr(m, c) = brr(i, c)
                m = m - 1
            End If
        Next
    Next
    [D1].Resize(UBound(crr, 1), UBound(crr, 2)) = crr
End If
End Sub

LSYYLW

2024-6-7-.zip (82.23 KB, 下载次数: 2)

2024-6-5 23:38 上传

点击文件名下载附件

LSYYLW

longwin 发表于 2024-6-5 22:38
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
    arr = Shee ...

再次感谢老师！非常抱歉，忘了说显示结果数字的位置了，您有时间帮我看一下14楼附件里有颜色的文字，帮我解决一下，拜托了！

longwin

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
    arr = Sheet11.Range("CI1216:FJ1217")
    brr = Sheet11.Range("CI3:FJ1218")
    ReDim crr(1 To 105, 1 To UBound(brr, 2))
    For c = 1 To UBound(brr, 2)
        s1 = CStr(arr(1, c))
        s2 = CStr(arr(2, c))
        m = UBound(crr, 1)
        For i = UBound(brr, 1) To 3 Step -1
            If CStr(brr(i - 1, c)) = s2 And CStr(brr(i - 2, c)) = s1 Then
                crr(m, c) = brr(i, c)
                Debug.Print m, i, brr(i, c)
                m = m - 1
            End If
        Next
    Next
    [D1].Resize(UBound(crr, 1), UBound(crr, 2)) = crr
End If
End Sub

LSYYLW

longwin 发表于 2024-6-6 08:54
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
    arr = Shee ...

再次感谢老师，代码非常非常好用，完美解决了，鲜花稍后为您献上。

LSYYLW

longwin 发表于 2024-6-6 08:54
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
    arr = Shee ...

老师您好：实在抱歉，今天又来麻烦您了，您有时间帮我看一下链接上的问题，拜托了！
https://club.excelhome.net/threa ... tml?_dsign=11e834d1