Question

这是我想做的事情，我真的不知道该怎么做或者是否有可能。我有一列生成一些值。假设列号为10。我想做什么...如果该列中的单元格的值是> 1我想绘制一个矩形（在下一个单元格中或靠近该单元格）（第11列同一行），并为其分配一个宏。宏将在单元格之后插入另一行，并且将绘制矩形，因此我必须以某种方式得到矩形的位置。有任何想法吗？非常感谢！

Answer 1

Sub Tester()
Dim c As Range

    For Each c In ActiveSheet.Range("A2:A30")
        If c.Value > 1 Then
            AddShape c.Offset(0, 1)
        End If
    Next c

End Sub


Sub AddShape(rng As Range)
    With rng.Cells(1).Parent.Shapes.AddShape(msoShapeRectangle, rng.Left, _
                                    rng.Top, rng.Width, rng.Height)
        .OnAction = "DoInsertAction"
    End With
End Sub

Sub DoInsertAction()
    Dim r As Long
    r = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Row
    ActiveSheet.Rows(r + 1).Insert Shift:=xlDown
End Sub

Answer 2

形状的替代方法是使用边框和双击事件。

将代码添加到工作表模块并更改第10列中的单元格值。然后双击包含边框的单元格。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   If Not Intersect(Target, Columns(11)) Is Nothing And Target.Count = 1 Then
        If Target.Offset(, -1).Value > 1 And Target.Borders.Count > 0 Then
          Target.Offset(1).EntireRow.Insert xlDown, False
          Cancel = True
        End If
   End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Columns(10)) Is Nothing And Target.Count = 1 Then
        If Target.Value > 1 And IsNumeric(Target) Then
            Target.Offset(, 1).BorderAround xlContinuous, xlMedium, xlColorIndexAutomatic
            Else
            Target.Offset(, 1).Borders.LineStyle = xlNone
        End If
    End If
End Sub

如果您真的想使用形状，请尝试以下内容。

在工作表模块中：

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Columns(10)) Is Nothing And Target.Count = 1 Then
        If Target.Value > 1 And IsNumeric(Target) Then
            AddShape Target.Offset(0, 1)
            Else
            DeleteShape Target.Offset(0, 1)
        End If
    End If
End Sub

在正常模块中：

Sub AddShape(rCell As Range)
    '// Check if shape already exists
    Dim shLoop As Shape
    For Each shLoop In rCell.Parent.Shapes
        If shLoop.Type = msoShapeRectangle And shLoop.TopLeftCell = rCell Then                
            Exit Sub
        End If
    Next shLoop

    With rCell.Parent.Shapes.AddShape(msoShapeRectangle, rCell.Left, rCell.Top, rCell.Width, rCell.Height)
        .OnAction = "ShapeClick"
    End With
End Sub

Sub DeleteShape(rCell As Range)
    Dim shLoop As Shape

    For Each shLoop In rCell.Parent.Shapes
        If shLoop.Type = msoShapeRectangle And shLoop.TopLeftCell = rCell Then
            shLoop.Delete
            Exit For
        End If
    Next
End Sub

Sub ShapeClick()
    With ActiveSheet.Shapes(Application.Caller)
        ActiveSheet.Rows(.TopLeftCell.Row + 1).Insert Shift:=xlDown
    End With
End Sub

Answer 3

这是一个大纲。 InsertRows()是一个插入行

的UDF

Sub FindErrors(ByVal myrange As Range)
    Dim xCell As range
    For Each xCell In myrange
        If xCell.Value >= 1 Then
            xCell.Offset(0, 1).BorderAround xlContinuous, xlThick
            xCell.Offset(0, 1) = InsertRow(range("A13:F13"))
        End If
    Next

End Sub

通过一个范围让它继续操作。基于另一个答案，我不确定边框着色是你正在寻找的，但你明白了。

Answer 4

如果有帮助，请参阅我的代码。基本上，它会在页面顶部绘制一个矩形，以便您可以随意使用它。


library(shiny)
library(shinydashboard)
library(shinyjs)
  ui <- dashboardPagePlus(
         header = dashboardHeaderPlus(
                   enable_rightsidebar = TRUE,
                  rightSidebarIcon = "gears"
    ),
    sidebar = dashboardSidebar(),
    rightsidebar = rightSidebar(
      id = "right_sidebar",
      background = "dark",
      rightSidebarTabContent(
        id = "tab_1",
        title = "Tab 1",
        icon = "desktop",
        active = TRUE,
        sliderInput(
          "obs",
          "Number of observations:",
          min = 0, max = 1000, value = 500
        )
      ),
      rightSidebarTabContent(
        id = "tab_2",
        title = "Tab 2",
        textInput("caption", "Caption", "Data Summary")
      ),
      rightSidebarTabContent(
        id = "tab_3",
        icon = "paint-brush",
        title = "Tab 3",
        numericInput("obs", "Observations:", 10, min = 1, max = 100)
      )
    ),
    dashboardBody(
      div(id = "tab1_out", verbatimTextOutput("tab1")),
      div(id = "tab2_out", verbatimTextOutput("tab2")),
      div(id = "tab3_out", verbatimTextOutput("tab3"))
    )
  )

server <-  function(input, output) { 
    
    output$tab1 <- renderPrint({
      "tab1"
    })
    
    output$tab2 <- renderPrint({
      "tab2"
    })
    
    
    output$tab3 <- renderPrint({
      "Tab3"
    })
    
    observeEvent(input$right_sidebar,{
      if(input$right_sidebar == "tab_1"){
        shinyjs::show("tab1_out")
        shinyjs::hide("tab2_out")
        shinyjs::hide("tab3_out")
      }else if(input$right_sidebar == "tab_2"){
        shinyjs::hide("tab1_out")
        shinyjs::show("tab2_out")
        shinyjs::hide("tab3_out")
      }else{
        shinyjs::hide("tab1_out")
        shinyjs::hide("tab2_out")
        shinyjs::show("tab3_out")
      }
    })
    
}

shinyApp(ui, server)

如何从VBA中绘制矩形并为它们分配宏？

4 个答案: