这样的填充效果，请帮忙实现一下，我对VBA真的不懂。

108937101

micch 发表于 2023-4-16 11:57

数字删除了，不会取消填充还是有

micch

108937101 发表于 2023-4-16 14:32
数字删除了，不会取消填充还是有

再加一下，删除同步删除颜色好了

xlj310

108937101 发表于 2023-4-16 14:32
数字删除了，不会取消填充还是有

把if Len()=0 then Exit Sub 改一下

xlj310

108937101 发表于 2023-4-16 14:32
数字删除了，不会取消填充还是有

Private Sub Worksheet_Change(ByVal Target As Range)
    Set rng = Target(1)
    Thisvalue = rng.Value
    r = rng.Row: c = rng.Column
    Dim 待着色 As Range, 不着色  As Range
    If r > 19 And c > 1 And c < 18 Then
        x = rng.Value
        r1 = Cells(19, c).End(3).Row
        If r1 = 1 Then Exit Sub
        c1 = Cells(r1, 256).End(1).Column
        If c1 = c Then Exit Sub
        Application.EnableEvents = False
        arr = Cells(r1, 1).Resize(, c1).Value
        For j = 20 To c1
            If arr(1, j) > 0 Then
                If Len(x) > 0 Then
                    If 待着色 Is Nothing Then
                        Set 待着色 = Cells(r, j)
                    Else
                        Set 待着色 = Union(待着色, Cells(r, j))
                    End If
                Else
                    If 不着色 Is Nothing Then
                        Set 不着色 = Cells(r, j)
                    Else
                        Set 不着色 = Union(不着色, Cells(r, j))
                    End If
                End If
            End If
        Next
        If Not 待着色 Is Nothing Then 待着色.Interior.Color = vbBlue
        If Not 不着色 Is Nothing Then 不着色.Interior.Pattern = xlPatternNone
        Set 待着色 = Nothing
        Set 不着色 = Nothing
        Application.EnableEvents = True
    End If
End Sub

108937101

micch 发表于 2023-4-16 18:23
再加一下，删除同步删除颜色好了

我就看不懂VBA
无奈呀，读书太少，可怜呀

108937101

xlj310 发表于 2023-4-16 19:54
把if Len()=0 then Exit Sub 改一下

不懂VBA，
只想要这个效果

micch

micch 发表于 2023-4-16 11:57

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Set Rng = Target(1)
   
3.     r = Rng.Row
   
4.     c = Rng.Column
   
5.     If r > 19 And c < 19 Then
   
6.         x = Rng.Value
   
7.         If Len(x) = 0 Then color0=xlnone else color0= vbgreen
   
8.         r1 = Cells(19, c).End(3).Row
   
9.         If r1 = 1 Then Exit Sub
   
10.         c1 = Cells(r1, 256).End(1).Column
    
11.         If c1 = c Then Exit Sub
    
12.         Application.EnableEvents = False
    
13.         For j = 20 To c1
    
14.             If Cells(r1, j).Value > 0 Then
    
15.                 Cells(r, j).Interior.Color = color0
    
16.             End If
    
17.         Next
    
18.         Application.EnableEvents = True
    
19.     End If
    
20. End Sub
    

复制代码

文件都删了，懒得测试，手工改下试试吧。如果有问题就自己学习一下自己改吧

108937101

xlj310 发表于 2023-4-16 19:55
Private Sub Worksheet_Change(ByVal Target As Range)
    Set rng = Target(1)
    Thisvalue = rng. ...

谢谢

xunanming

参考,看是否需要的结果.......................

108937101

xunanming 发表于 2023-4-17 12:56
参考,看是否需要的结果.......................

谢谢，