Excel代码问题，非常感谢！

LSYYLW · 发表于 2024-12-7 19:33

2024-12-7.zip (6.05 KB, 下载次数: 3)

quqiyuan · 发表于 2024-12-7 22:47

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

quqiyuan · 发表于 2024-12-7 22:49

代码如下。。。。
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Address = "$N$1" Then
      arr = [h21:h220]
      ReDim brr(1 To UBound(arr), 0)
      For i = 1 To UBound(arr)
         If arr(i, 1) > 1 Then arr(i, 1) = 2
         s = s & arr(i, 1)
      Next
      For m = 1 To UBound(arr)
         i = InStr(m, s, "2")
         x = InStr(i, s, "0")
         y = InStr(i, s, "1")
         Z = Application.Min(x, y)
         If y > 0 Then ii = InStr(y, s, "2")
         If ii > y And y <> 0 Then
            ss = Mid(s, i, y - i + 1)
            zZ = InStrRev(ss, "2")
            j = j + 1
            brr(j, 0) = zZ
            j = j + 1
            brr(j, 0) = ii - zZ - i
            m = ii - 1
         ElseIf ii = 0 And y > 0 Then
            ss = Mid(s, i, y - i + 1)
            zZ = InStrRev(ss, "2")
            j = j + 1
            brr(j, 0) = zZ
            j = j + 1
            brr(j, 0) = 201 - zZ - i
            m = 200
         End If
         If y = 0 Then
            j = j + 1
            brr(j, 0) = 201 - i
            m = 200
         End If
      Next
      [n78].CurrentRegion.ClearContents
      [n78].Offset(-j + 1).Resize(j) = brr
End If
Application.EnableEvents = True
End Sub

LSYYLW · 发表于 2024-12-7 22:57

quqiyuan 发表于 2024-12-7 22:47
参与一下，仅供参考。。。。

万分的感谢老师，代码非常非常好用，鲜花明天为您献上。

LSYYLW · 发表于 2024-12-8 08:37

2024-12-8-.zip (16.53 KB, 下载次数: 2)

LSYYLW · 发表于 2024-12-8 08:39

quqiyuan 发表于 2024-12-7 22:49
代码如下。。。。
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents ...

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

quqiyuan · 发表于 2024-12-8 13:17

LSYYLW 发表于 2024-12-8 08:39
老师您好：又来麻烦您了，您有时间帮我看一下5楼附件里有颜色单元格里的文字，帮我解决一下，拜托您了！

quqiyuan · 发表于 2024-12-8 13:18

代码如下。。。
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Address = "$N$1" Then
      arr = [h21:h220]
      ReDim brr(1 To UBound(arr), 0)
      For i = 1 To UBound(arr)
         If arr(i, 1) > 1 Then arr(i, 1) = 2
         s = s & arr(i, 1)
      Next
      For m = 1 To UBound(arr)
         i = InStr(m, s, "2")
         x = InStr(i, s, "0")
         y = InStr(i, s, "1")
         Z = Application.Min(x, y)
         If y > 0 Then ii = InStr(y, s, "2")
         If ii > y And y <> 0 Then
            ss = Mid(s, i, y - i + 1)
            zZ = InStrRev(ss, "2")
            j = j + 1
            brr(j, 0) = zZ
            j = j + 1
            brr(j, 0) = ii - zZ - i
            m = ii - 1
         ElseIf ii = 0 And y > 0 Then
            ss = Mid(s, i, y - i + 1)
            zZ = InStrRev(ss, "2")
            j = j + 1
            brr(j, 0) = zZ
            j = j + 1
            brr(j, 0) = 201 - zZ - i
            m = 200
         End If
         If y = 0 Then
            j = j + 1
            brr(j, 0) = 201 - i
            m = 200
         End If
      Next
      Range([n78], [n78].End(3)).ClearContents
      [n78].Offset(-j + 1).Resize(j) = brr
End If
Application.EnableEvents = True
End Sub

LSYYLW · 发表于 2024-12-8 15:25

quqiyuan 发表于 2024-12-8 13:17

万万分的感谢老师，代码非常非常好用，您完美的为我解决了问题。

LSYYLW · 发表于 2024-12-10 17:32

2024-12-10---.zip (16.63 KB, 下载次数: 2)

		自动登录	找回密码
密码			免费注册

[求助] Excel代码问题，非常感谢！

评分

评分

评分

评分