Question

可以创建一个进行数学求和的宏吗？我不知道怎么解释。但我已经看到了另一个答案，但我无法为我工作。

以下是我要做的事情：

我有这个工作表

iTEM 1 [1]：https://i.stack.imgur.com/v7vXF.jpg

我将值设为下图。根据小组进行搜索并在“可用”中进行数学总和。

项目2 [2]：https://i.stack.imgur.com/wQnxu.png

结果如下：

项目3 [3]：https://i.stack.imgur.com/ify7J.png

Answer 1

为了回答你的问题，舌头在脸颊，Excel非常善于做数学总和，并且在VBA的帮助下它获得了多样性。为了证明这一点，下面的代码并不仅仅取决于您在“更新”中的选择。表格，它包含＆＃39;更新＆＃39;中的所有项目。将表格发布到数据库＆＃39;片。点击两次，然后两次完成。没有休息。

Option Explicit

    Enum Nup                                    ' Sheet Update
        NupFirstDataRow = 2
        NupName = 1                             ' 1 = column A
        NupGroup = 5
        NupQty = 7
    End Enum

    Enum Ndt                                    ' Sheet Data
        NdtFirstDataRow = 2
        NdtName = 1                             ' 1 = column A
        NdtGroup = 3
        NdtQty                                  ' = 4
        NdtOffset = 3                           ' NdtGroup + NdtOffset = Group2 column
    End Enum


Sub UpdateQuantity()
    ' 09 Jan 2018

    Dim WsUpdate As Worksheet                   ' Sheet where data are entered
    Dim WsData As Worksheet                     ' Sheet where data are updated
    Dim Rng As Range
    Dim SearchRng As Range
    Dim Itm As String                           ' an item's name
    Dim Qty As Long                             ' Update quantity (designed for integers)
    Dim Rt As Long                              ' target row in WsData
    Dim Rl As Long                              ' last row in WsUpdate
    Dim ClmOffset As Long                       ' helper
    Dim R As Long                               ' row counter in WsUpdate
    Dim Ct As Ndt                               ' column in WsData

    Set WsUpdate = Worksheets("Update")
    Set WsData = Worksheets("Database")

    With WsData
        Rl = .Cells(.Rows.Count, NupName).End(xlUp).Row
        Set Rng = Range(.Cells(NdtFirstDataRow, NdtName), .Cells(Rl, NdtQty + NdtOffset))
    End With

    Application.ScreenUpdating = False
    With WsUpdate
        Rl = .Cells(.Rows.Count, NupName).End(xlUp).Row
        For R = NupFirstDataRow To Rl
            Itm = .Cells(R, NupName).Value
            Set SearchRng = Range(Rng.Columns(NdtName), Rng.Columns(NdtName))
            If CellAddress(Itm, SearchRng, Rt) Then
                Itm = .Cells(R, NupGroup).Value
                With WsData
                    Set SearchRng = Range(.Cells(R, NdtGroup), .Cells(R, NdtGroup + NdtOffset))
                End With
                If CellAddress(Itm, SearchRng, Ct) Then
                    Qty = Val(.Cells(R, NupQty).Value)
                    With WsData.Cells(Rt, Ct + 1)
                        Qty = Val(.Value) + Qty
                        .Value = Qty
                    End With
                End If
            End If
        Next R
    End With
    Application.ScreenUpdating = True
End Sub

Private Function CellAddress(ByVal Itm As String, _
                             SearchRange As Range, _
                             Rc As Long) As Boolean
    ' 09 Jan 2018
    ' Rc is a return variable (either column or row = 0 if not found)

    Dim ClmRng As Range
    Dim Fnd As Range
    Dim i As Long

    With SearchRange
        Set Fnd = .Find(What:=Itm, After:=.Cells(.Cells.Count), _
                        LookIn:=xlValues, LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                        MatchCase:=False)
        If Fnd Is Nothing Then
            Rc = 0
            MsgBox "Item """ & Itm & """ wasn't found.", _
                   vbInformation, "Update failed"
        Else
            Rc = IIf(.Rows.Count > 1, Fnd.Row, Fnd.Column)
            CellAddress = True
        End If
    End With
End Function

代码顶部的枚举控制使用哪些列和行。您可以修改这些数字。请注意，数据库中的数量列必须与“组”列相邻。您可能需要更改的代码中唯一的其他位置涉及两个工作表的名称。代码必须位于同一工作簿中的标准代码模块中。

VBA基于两个标准进行复制和粘贴

1 个答案: