VBA to Copy and Paste Based on Two Criterias - vba

Question

It's is possible to create a macro that do a mathematical sum?
I don't know how to explain. But I already saw another answers but I could not make work for me.
Here is what I trying to do:
I have this Worksheet
iTEM 1 [1]: https://i.stack.imgur.com/v7vXF.jpg
And I to put values as the image below. Make a search and make a mathematical sum in the "available" according with the group.
ITEM 2 [2]: https://i.stack.imgur.com/wQnxu.png
Here would be the result:
ITEM 3 [3]: https://i.stack.imgur.com/ify7J.png

Answer 1

To answer your question, tongue in cheek, Excel is very good at doing mathematical sums, and with the help of VBA it gains versatility. To prove the point, the code below doesn't only act upon your selection in the 'Update' sheet, it takes all the items in the 'Update' sheet and posts them to the 'Database' sheet. Click twice and it's done twice over. There is no break.
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
The enumerations at the top of the code control which columns and rows are used. You can modify these numbers. Observe that the quantity columns in the Database must be adjacent to the Group columns. The only other place in the code you may have to change concerns the names of the two worksheets. The code must be in a standard code module in the same workbook.