根據用戶提供的寬度和高度繪製表格

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