根据用户提供的宽度和高度绘制表格

Question

我在Excel中使用VBA非常新。我想完成的是这个。当用户输入5的长度时，则必须将5列显示为红色。然后，当用户输入6的宽度时，则必须将6行勾勒为红色。例如：

我迄今这段代码：

表上的变化：

Private Sub Worksheet_Change(ByVal Target As Range) 
    If (Target.Address = "$A$2") Then 
    Call Draw2DTankl 
    ElseIf (Target.Address = "$B$2") Then 
    Call Draw2DTankw 
    End If 
End Sub 

Draw2DTankl：

Sub Draw2DTankl() 

    On Error Resume Next 
    Cells(2, 4).Value = "" 
    Dim x As Range 
    Set x = Worksheets("Sheet1").Cells 

    x.Borders.LineStyle = xNone 

    Range("A1") = "Length" 


    Dim Length As Integer 


    Length = CInt(Cells(2, 1).Value) 


    If (Length > 30) Then 
    MsgBox "A length of a maximum 30 is allowed" 
    Exit Sub 
    End If 
    If (Length < 0) Then 
    MsgBox "Invalid length value entered" 
    Exit Sub 
    End If 


    Dim Rws As Long, Rng As Range, r As Range 
    If (Length > 0) Then 
    Rws = 20 
    Set Rng = Range(Cells(20, "H"), Cells(Rws, 8 + Length - 1)) 

    For Each r In Rng.Cells 

      With r.Borders 

       .LineStyle = xlContinuous 
       .Weight = xlMedium 
       .ColorIndex = 3 

      End With 
    Next r 
    End If 

If (Err.Number <> 0) Then 
    MsgBox Err.Description 
End If 

End Sub 

Draw2DTankw：

Sub Draw2DTankw() 

    On Error Resume Next 
    Cells(2, 4).Value = "" 
    Dim x As Range 
    Set x = Worksheets("Sheet1").Cells 

    x.Borders.LineStyle = xNone 


    Range("B1") = "Width" 


    Dim Width As Integer 



    Width = CInt(Cells(2, 2).Value) 


    If (Width > 30) Then 
    MsgBox "A width of a maximum 30 is allowed" 
    Exit Sub 
    End If 
    If (Width < 0) Then 
    MsgBox "Invalid Width value entered" 
    Exit Sub 
    End If 


    Dim Col As Long, Rng As Range, r As Range 
    If (Width > 0) Then 
    Col = 21 
    Set Rng = Range(Cells(21, "H"), Cells(Col, 8 + Length - 1)) 

    For Each r In Rng.Cells 

      With r.Borders 

       .LineStyle = xlContinuous 
       .Weight = xlMedium 
       .ColorIndex = 3 

      End With 
    Next r 
    End If 

If (Err.Number <> 0) Then 
    MsgBox Err.Description 
End If 

End Sub 

请帮助我。我的代码不起作用。长度有效，但是当我改变宽度时会刹车。

进入我的长平：

这是正确的。不过，如果我进入6宽度发生这种情况：（我的长短也自败）

我为此很长的帖子道歉！

Answer 1

它看起来像在Draw2DTankw你有宽度以上声明但在RNG您使用长度

昏暗宽度作为整数宽度= CINT（细胞（2,2）。价值）

设置RNG =范围（将细胞（21， “H”），将细胞（山口，8 +长度 - 1））

我修改您的代码通过延伸范围，包括绘制高度和宽度宽度。这与我测试它。

Private Sub Worksheet_Change(ByVal Target As Range) 
    If (Target.Address = "$A$2") Or (Target.Address = "$B$2") Then 
    DrawTable 
    End If 
End Sub 

Sub DrawTable() 

    On Error Resume Next 
    Cells(2, 4).Value = "" 
    Dim x As Range 
    Set x = ActiveSheet.Cells 

    x.Borders.LineStyle = xNone 

    Range("A1") = "Length" 


    Dim Length As Integer 
    Length = CInt(Cells(2, 1).Value) 
    'Combined Width sections 
    Dim Width As Integer 
    Width = CInt(Cells(2, 2).Value) 

    If (Length > 30) Then 
    MsgBox "A length of a maximum 30 is allowed" 
    Exit Sub 
    ElseIf (Width > 30) Then 
    MsgBox "A width of a maximum 30 is allowed" 
    Exit Sub 
    ElseIf (Length < 0) Then 
    MsgBox "Invalid length value entered" 
    Exit Sub 
    ElseIf (Width < 0) Then 
    MsgBox "Invalid Width value entered" 
    Exit Sub 
    End If 


    Dim Rws As Long, Rng As Range, r As Range 
    If (Length > 0) Then 
    Rws = 20 
    'Added width to cells(rws) 
    Set Rng = Range(Cells(20, "H"), Cells(Rws + Width - 1, 8 + Length - 1)) 

    For Each r In Rng.Cells 

      With r.Borders 

       .LineStyle = xlContinuous 
       .Weight = xlMedium 
       .ColorIndex = 3 

      End With 
    Next r 
    End If 

If (Err.Number <> 0) Then 
    MsgBox Err.Description 
End If 
End Sub