Question

我一直在尝试使表自动化以实时计算一些值，并准备在将来添加行。我想添加到此表中的简单项目是链接到宏的“ +”和“-”符号（形状或图像），该宏可以更改另一列中的值。一次做起来很简单，但是我希望我的总体宏能够将形状及其宏复制/粘贴到下一行。

例如：一种。在A1中存在分配了宏的加号以单击以将B1中的值增加1 b。启动另一个宏会将图像从A1复制/粘贴到A2，并且分配的宏应增加B2中的值

到目前为止，我已经能够复制/粘贴图像，但是不幸的是，所有这些操作都是使两个图像都能增加B1中的值。

如果有可能，有什么想法或可能性吗？

这是代码的一部分：为了在这里进行查询，我们假设在形状为“ Plus 50”的宏中，该宏将B1中的值增加1。

For i = 1 to 50
   ActiveSheet.Shapes("Plus 50").Copy
   Cells(i, 1).PasteSpecial
Next i

增量宏供参考。

Sub Plus 50_Click()
   Dim a As Integer
   a = Cells(1, 2)
   Cells(1, 2) = a + 1
End Sub

将完全不希望有任何帮助，因为我目前正在使用大量滚动条，这些滚动条需要花费很多时间来加载，所以它将大大加快excel工作表的速度。

谢谢！

Answer 1

我之前编写了一个模块，用于添加自定义按钮以添加/删除表中的行。我已针对您的用例对其进行了一些修改，以增加/减少目标单元格的值。这并不是您所要的，因为按钮浮在目标单元格的右边，但是它非常接近，您可以修改draw方法以适合您的用例。

按钮位于selection_change上，如果选择不在表（或目标列）之外，则将其删除。只有1组按钮-在我的原始用例中，我们不想使用形状来增加文件大小（可能与滚动条时出现相同的问题）。

您必须使用目标工作表（即listobject）上的表
drawButtons（）中有一个选项可以将按钮限制为特定的列-如果要使用此列，请取消注释并添加正确的列名。
添加以下代码后，只需单击表（或目标表列）中的任意位置，按钮就会出现。

将此添加到目标工作表模块中

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Call drawButtons(Target)
End Sub

添加代码模块并粘贴以下内容：

Option Explicit

'Author:        Valon Miller
'Description:   This module draws custom increment and decrement
'               buttons on a list object that is intersected by the
'               supplied target range.
'Usgage:        Simply Call drawButtons(Target) from the
'               selection_Change event of any worksheet.

Private Const btnDiameter As Integer = 21
Private Const btnPadding As Integer = 3
Private btnLeft As Integer

Public Sub drawButtons(Target As Range)
    Dim sh As Worksheet

    Dim btnTop As Integer

    Dim rng As Range
    Dim objrow As ListRow

    Dim appScreenUpdating As Boolean
    Dim appCalculation As XlCalculation
    Dim appEnableEvents As Boolean

    On Error GoTo uhoh

    With Application
        'Remember Settings
        appScreenUpdating = .ScreenUpdating
        appCalculation = .Calculation
        appEnableEvents = .EnableEvents
        'Modify Settings
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

    Set sh = Target.Parent

    'delete buttons if they exist
    deleteButtons sh

    'Check if the target intersects a DataBodyRange
    Set objrow = Range_getListRow(Target)
    If objrow Is Nothing Then GoTo getout

    'Uncomment to restrict the buttons to appear only when a specificed column is selected, by name
    'If Intersect(Target, objrow.Parent.ListColumns("Column1").DataBodyRange) Is Nothing Then GoTo getout

    'Derive the target range of the buttons
    Set rng = Intersect(Target, objrow.Range)
    Set rng = rng.Cells(1, 1).Offset(0, rng.Columns.Count)

    'Initialize Position Variables
    btnTop = rng.Top + ((rng.Height - btnDiameter) / 2)
    btnLeft = rng.Left + 3 + IIf(Range_getValidationType(rng.Cells(1, -1)) = 3, 16, btnPadding)

    'Draw Increment Button
    getNewButton sh, "IncrementButton", "+", "add_Click", btnLeft, btnTop, btnDiameter, msoShapeStylePreset37

    'Draw Decrement Button
    getNewButton sh, "DecrementButton", ChrW(&H2212), "sub_Click", nextLeft, btnTop, btnDiameter, msoShapeStylePreset37

getout:

    With Application
        'Restore Settings
        .ScreenUpdating = appScreenUpdating
        .Calculation = appCalculation
        .EnableEvents = appEnableEvents
    End With

    Exit Sub

uhoh:

    On Error Resume Next

    deleteButtons sh

    GoTo getout

End Sub

'************************************************************
'*                     Custom Methods                       *
'************************************************************

Private Function nextLeft() As Integer
    btnLeft = btnLeft + btnDiameter + btnPadding
    nextLeft = btnLeft
End Function

Private Function getNewButton(sh As Worksheet, strName As String, strCaption As String, macro As String, _
    intLeft As Integer, intTop As Integer, intDiameter As Integer, shpStyle As MsoShapeStyleIndex) As Shape

    Dim shp As Shape

    Set shp = sh.Shapes.AddShape(msoShapeOval, intLeft, intTop, intDiameter, intDiameter)

    With shp

        .name = strName
        .TextFrame.Characters.Text = strCaption
        .TextFrame.VerticalAlignment = xlVAlignCenter
        .TextFrame.HorizontalAlignment = xlHAlignCenter
        .TextEffect.FontBold = msoTrue
        .TextEffect.FontSize = 15
        .OnAction = macro
        .Placement = xlFreeFloating
        .shapeStyle = shpStyle

        'msoShapeStylePreset    Theme
        '---------------------------------
        'msoShapeStylePreset36  Black
        'msoShapeStylePreset37  Light Blue
        'msoShapeStylePreset38  Orange
        'msoShapeStylePreset39  Grey
        'msoShapeStylePreset40  Yellow
        'msoShapeStylePreset41  Dark Blue
        'msoShapeStylePreset42  Green

    End With

End Function

Private Sub deleteButtons(sh As Worksheet)
    Dim shp As Shape
    Dim buttonNames() As String
    buttonNames = Split("IncrementButton,DecrementButton", ",")
    On Error Resume Next
    For Each shp In sh.Shapes
        If Array_containsValue(buttonNames, shp.name) Then shp.Delete
    Next shp
End Sub

'************************************************************
'*                          Events                          *
'************************************************************

Public Sub add_Click()
    Dim newRecord As ListRow
    Dim objList As ListObject
    Dim sh As Worksheet
    Dim rng As Range
    Dim shp As Shape

    On Error GoTo uhoh

    Set sh = ActiveSheet
    Set shp = getShapeByName("IncrementButton", , sh)
    Set rng = getShapeRange(shp).Offset(0, -1)
    Set objList = rng.ListObject

    'Do Stuff
    rng = rng + 1

    Exit Sub

uhoh:

    MsgBox "Oops, unable to increment!", vbCritical, "Uhoh"

End Sub

Public Sub sub_Click()
    Dim selectedRecord As ListRow
    Dim objList As ListObject
    Dim sh As Worksheet
    Dim rng As Range
    Dim shp As Shape

    On Error GoTo uhoh

    Set sh = ActiveSheet
    Set shp = getShapeByName("DecrementButton", , sh)
    Set rng = getShapeRange(shp).Offset(0, -1)
    Set objList = rng.ListObject

    'Do Stuff
    rng = rng - 1

    Exit Sub

uhoh:

    MsgBox "Oops, unable to decrement!", vbCritical, "Uhoh"

End Sub

'************************************************************
'*                     Generic Methods                      *
'************************************************************

Private Function Array_isEmpty(arr As Variant)
' This function returns true if array is empty

  Dim l As Long

  On Error Resume Next
  l = Len(Join(arr))
  If l = 0 Then
    Array_isEmpty = True
  Else
    Array_isEmpty = False
  End If

  If Err.Number > 0 Then
      Array_isEmpty = True
  End If

  On Error GoTo 0

End Function

Private Function Array_containsValue(myArray As Variant, item As Variant)
    Dim i As Integer
    If Array_isEmpty(myArray) Then Array_containsValue = False: Exit Function
    For i = LBound(myArray) To UBound(myArray)
        If item = myArray(i) Then Array_containsValue = True: Exit Function
    Next i
    Array_containsValue = False
End Function

Private Function getListObjectByName(strName As String) As ListObject
    Dim sh As Worksheet
    Dim tbl As ListObject
    For Each sh In ThisWorkbook.Sheets
        For Each tbl In sh.ListObjects
            If tbl.name = strName Then Set getListObjectByName = tbl: Exit Function
        Next tbl
    Next sh
    Set getListObjectByName = Nothing
End Function

Private Function Range_getListRow(Target As Range) As ListRow
    'Check if target intersects with a list object
    If Not Target.ListObject Is Nothing Then
        'Check if the list object has a DataBodyRange
        If Not Target.ListObject.DataBodyRange Is Nothing Then
            'Check if the first row of the target range is in the DataBodyRange
            If Not Intersect(Target.Rows(1), Target.ListObject.DataBodyRange) Is Nothing Then
                'Return ListRow that intersects with the first row in the target range
                Set Range_getListRow = Target.ListObject.ListRows(Target.Rows(1).Row - Target.ListObject.Range.Row)
                Exit Function
            End If
        End If
    End If
    'No intersect, return nothing
    Set Range_getListRow = Nothing
End Function

Private Function Range_getValidationType(rng As Range) As Integer
    'Name                   Value   Description
    'xlValidateInputOnly    0       Validate only when user changes the value.
    'xlValidateWholeNumber  1       Whole numeric values.
    'xlValidateDecimal      2       Numeric values.
    'xlValidateList         3       Value must be present in a specified list.
    'xlValidateDate         4       Date values.
    'xlValidateTime         5       Time values.
    'xlValidateTextLength   6       Length of text.
    'xlValidateCustom       7       Data is validated using an arbitrary formula.
    Dim t As XlDVType
    On Error GoTo uhoh
    Range_getValidationType = rng.Validation.Type
    Exit Function
uhoh:
    Range_getValidationType = -1
End Function

Private Function getShapeByName(nm As String, Optional inWb As Workbook, Optional inSh As Worksheet) As Shape
    Dim shp As Shape
    Dim wb As Workbook
    Dim sh As Worksheet
    Dim mySheets As Collection
    Dim i As Integer

    On Error GoTo uhoh

    'Get sheets to search
    Set wb = IIf(inWb Is Nothing, ThisWorkbook, inWb)
    Set mySheets = New Collection
    If inSh Is Nothing Then
        For Each sh In wb.Sheets
            mySheets.Add sh
        Next sh
    Else
        mySheets.Add inSh
    End If

    'Search for shape
    For i = 1 To mySheets.Count
        For Each shp In mySheets(i).Shapes
            If shp.name = nm Then Set getShapeByName = shp: Exit Function
        Next shp
    Next i

uhoh:

    Set getShapeByName = Nothing

End Function

Private Function getShapeRange(shp As Shape) As Range
    Dim x As Integer
    Dim y As Integer
    x = shp.Left + (shp.Width / 2)
    y = shp.Top + (shp.Height / 2)
    Set getShapeRange = Range_getByCoordinate(shp.Parent, x, y)
End Function

Private Function Range_getByCoordinate(sh As Worksheet, x As Integer, y As Integer) As Range
    Dim nCol, nRow As Range
    For Each nCol In sh.Columns
        If nCol.Left < x And nCol.Left + nCol.Width > x Then
            For Each nRow In sh.Rows
                If nRow.Top < y And nRow.Top + nRow.Height > y Then
                    Set Range_getByCoordinate = sh.Cells(nRow.Row, nCol.Column): Exit Function
                End If
            Next nRow
        End If
    Next nCol
End Function

使用链接的宏复制形状

1 个答案: