单元格输入数据时添加虚线框格，删除数据时取消虚线框格

宜信

各位老师好！请会VBA的老师帮我看看，怎么修改我目前表格的代码才能达到我想要的要求。表格的样式模板，请看附件，望老师有时间帮我看看。十分感谢！(excel2010版)
        目前表格虽然能够在不改变1-2行格式的前提下，从第3行开始，当第6列单元格有数据时添加虚线框格，删除数据时取消虚线框格。目前弊端：当到达1000行时代码运行速度变慢。
要求：1、提升代码运行速度。
              2、在不改变1-2行格式的前提下，从第3行开始，在1-6列的任何一列单元格输入数据时添加虚线框格，删除数据时取消虚线框格（注：在1-6列同一行任何一个单元格有数据时，不取消虚线框格）。
              3、取消虚线框格的同时删除该行数据。


Private Sub Worksheet_Change(ByVal Target As Range)

On Error Resume Next '忽略错误提醒
    Dim nR1%, nR2% '定义
    If Target.Row < 3 Then Exit Sub
    If Target.CountLarge <> 1 Then Exit Sub
    If Target.Column * Target.Count <> 6 Then Exit Sub
    If Target.Row < Range("f" & Rows.Count).End(xlUp).Row Then Exit Sub
    nR2 = Target.Row
    If nR2 = 1 Then
        nR1 = 1
    Else
        If Target.Offset(-1).Value = "" Then
            nR1 = Target.End(xlUp).Row + 1
        Else
            nR1 = nR2
        End If
    End If
    With Range(Range("a" & nR1), Range("w" & nR2 + 1))
        .Borders.LineStyle = Target.Value <> ""
        .HorizontalAlignment = xlCenter  '添加表格线
        .VerticalAlignment = xlCenter '添加表格线
        .Font.Bold = True
        Call 变为虚线
    End With
End Sub

Sub 变为虚线()
Dim i As Long
With Sheet1
    For i = 3 To .Cells(65536, 6).End(xlUp).Row
        With .Range(.Cells(i + 1, 1), .Cells(i, 23))
            .Borders.LineStyle = xlDash     '内格虚线
        End With
     Next i
  End With
End Sub

568132828

这个为什么要用宏写呢，用条件格式他不香吗

宜信

568132828 发表于 2021-1-15 14:38
这个为什么要用宏写呢，用条件格式他不香吗

条件格式不知能否达到我想要的效果：
如图所示：1、当B10单元格输入有数据时，B4到B9有没有数据都能自动填充A4到J10的框格线；
               2、当删除B10单元格的数据时，自动取消A7到J10的框格线；如再次删除B6的数据时，则再次取消A3到J6的框格线，但是A1至J2的框格线不受影响（即不取消框格线）。

    以上效果目前我上传的附件已经到达了，只是单元格达到1000行以后运行会变慢，所以还得请各位老师帮帮忙优化一下代码代码。

目前想要达到以下效果：
         在不改变1-2行格式的前提下，从第3行开始，在1-6列的任何一列单元格输入数据时添加虚线框格，删除数据时取消虚线框格（注：在1-6列同一行任何一个单元格有数据时，不取消虚线框格，除非1至6列同一行的数据全部删除方可取消该行的框格线）。
取消虚线框格的同时删除该行数据。

568132828

条件格式，新建，使用公式。
=$a1<>""
应用于：$a:$j

宜信

568132828 发表于 2021-1-18 09:14
条件格式，新建，使用公式。
=$a1""
应用于：$a:$j

        您好！很感谢百忙之中来回复我的问题。用条件格式这个公式没有办法实现我的需求！这个公式如果是逐行输入数据或者逐行删除数据都是符合要求，但是隔几行才输入数据就只有输入数据的行自动添加框格线，中间没有数据的行就没有办法实现自动添加框格线，当删除数据行时，也仅仅只能实现取消刚删除数据这一行的框格线，中间没有数据的框格线没有办法取消！
        这个公式只能实现图1-图2的效果！当直接在A12输入数据时，这个公式就只能实现自动添加A12至J12的框格线；当删除A12的数据时，也只能自动取消A12至J12的框格线！


          我要的是图3-图4的效果。即当在A12输入数据时连同A6至J11的框格线也能自动添加，当删除A12的数据时也连同A6至J11的框格线一起取消。

zjzyj

Dim x1
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next '忽略错误提醒
    If Target.Row < 3 Then Exit Sub
    If Target.CountLarge <> 1 Then Exit Sub
    If Target.Column > 6 Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    x2 = 2
    For i = 1 To 6
        x2 = WorksheetFunction.Max(x2, Cells(Rows.Count, i).End(xlUp).Row)
    Next
    If x1 = x2 Then Exit Sub
    If x1 < x2 Then x1 = x1 + 1: flag = True
    If x2 < x1 Then x2 = x2 + 1: flag = False
    With Range(Cells(x1, "A"), Cells(x2, "W"))
        .Borders.LineStyle = flag
        .HorizontalAlignment = xlCenter  '添加表格线
        .VerticalAlignment = xlCenter '添加表格线
        .Font.Bold = True
        If flag = True Then .Borders.LineStyle = xlDash
    End With
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    x1 = 2
    For i = 1 To 6
        x1 = WorksheetFunction.Max(x1, Cells(Rows.Count, i).End(xlUp).Row)
    Next
End Sub

zjzyj

计算行号的两段过程是一样的，所以可以拿到外面共用。

Dim x1

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next '忽略错误提醒
    If Target.Row < 3 Then Exit Sub
    If Target.CountLarge <> 1 Then Exit Sub
    If Target.Column > 6 Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    x2 = HH
    If x1 = x2 Then Exit Sub
    If x1 < x2 Then x1 = x1 + 1: flag = True
    If x2 < x1 Then x2 = x2 + 1: flag = False
    With Range(Cells(x1, "A"), Cells(x2, "W"))
        .Borders.LineStyle = flag
        .HorizontalAlignment = xlCenter  '添加表格线
        .VerticalAlignment = xlCenter '添加表格线
        .Font.Bold = True
        If flag = True Then .Borders.LineStyle = xlDash
    End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    x1 = HH
End Sub

Function HH()
    x = 2
    For i = 1 To 6
        x = WorksheetFunction.Max(x, Cells(Rows.Count, i).End(xlUp).Row)
    Next
    HH = x
End Function

宜信

zjzyj 发表于 2021-1-19 08:42
计算行号的两段过程是一样的，所以可以拿到外面共用。

Dim x1

十分感谢老师的帮忙，问题得以解决。不过你说的“计算行号的两段过程是一样的，所以可以拿到外面共用”这确实不明白！还望老师解惑，我是一小白，最好上传附件让我更能看得明白些，谢谢！谢谢！谢谢！

zjzyj

宜信 发表于 2021-1-19 23:45
十分感谢老师的帮忙，问题得以解决。不过你说的“计算行号的两段过程是一样的，所以可以拿到外面共用”这 ...

代码简单复制过去就可以了

宜信

zjzyj 发表于 2021-1-20 00:28
代码简单复制过去就可以了

您好，测试后还有一个问题，如图所示A7:C8单元格，在已添加框格线的表格内单元格合并居中后，随后又撤销了内单元格合并居中，此时的A7:C8单元格没有自动添加框格线，请问老师，如何才能实现自动添加？