在范围内查找匹配的单元格值，如果未找到匹配项，则粘贴单元格值

Question

我试图遍历标题为 mineral 的范围，并在标题为 compList 的单独列表中找到匹配的单元格，仅当特定单元格范围包含数值时。如果未找到匹配项，则将单元格（字符串）复制并粘贴到 compList 中的下一个可用行以及相邻的单元格（数字）。如果找到匹配项，则只会将相邻的单元格添加到现有单元格中。

到目前为止，这是我设法做到的，它会按预期粘贴单元格值和相邻单元格，但它会继续粘贴这些单元格，即使它们已经存在于 compList 中。我无法创建代码来将这些值添加到现有匹配中，因为我试图找出这个问题。

如果可以，请添加一个简短的评论行，以便我学习！

提前致谢。

        
        Dim wsMC As Worksheet
        Dim emptyRow As Long
        Dim mineral, cell, compList As Range, i
        
        
        Set wsMC = Sheets("Mining Calculator")
        Set mineral = Range("B10:B29")
        Set compList = Range("I11:I30")
        emptyRow = wsMC.Cells(Rows.Count, "I").End(xlUp).Row + 1

   
        If Application.CountA(wsMC.Range("D10:D29")) = 0 Then                     ' Checks if "D" column contains any value
            MsgBox ("Nothing to Add")                                             ' If 'D' column is empty (equals 0) then nothing happens, otherwise go to else
            
            Else
            For Each cell In mineral                                              'For each cell located in 'mineral' range
                If cell.Offset(0, 2).Value = 0 Then GoTo skip                     'If cells 2 columns from 'cell' is empty (equals 0) then skip, otherwise
                
                If Not StrComp("cell", "complist", vbTextCompare) = 0 Then        'Check if 'cell' value already exists within range 'compList' if not then
                        Cells(emptyRow, 9).Value = cell.Value                        'Copy 'cell' value to new row in 'compList'
                        Cells(emptyRow, 10).Value = cell.Offset(0, 3).Value          'Copy adjacent cell values from 'cell' to corresponding match in 'compList'
                        Cells(emptyRow, 11).Value = cell.Offset(0, 2).Value          'Copy adjacent cell values from 'cell' to corresponding match in 'compList'
                        Cells(emptyRow, 12).Value = cell.Offset(0, 4).Value          'Copy adjacent cell values from 'cell' to corresponding match in 'compList'
                        emptyRow = emptyRow + 1                                   'Add 1 to emptyRow to avoid replacing last cell value in 'compList'
                        
                    
                        Else                                                      'If 'cell' exists in 'compList' only add adjacent cells to the matching row
                        MsgBox ("it already exists")
                        Exit For
                End If
                
skip:
            Next cell
        End If
End Sub

Answer 1

If Exists Then Sum up Else New Entry

Option Explicit

Sub UpdateMinerals()
    
    ' s - Source (read from) ('Mineral')
    ' d - Destination (written to) ('CompList')
    
    Const scOffset As Long = 2 ' from column 'B' to column 'D'
    
    Dim scOffsets As Variant: scOffsets = VBA.Array(1, 2, 3)
    Dim dcOffsets As Variant: dcOffsets = VBA.Array(2, 1, 3)
    Dim oUpper As Long: oUpper = UBound(scOffsets)
    
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Mining Calculator")
    
    Dim slRow As Long: slRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    Dim srg As Range: Set srg = ws.Range("B10:B" & slRow)
    Dim dlRow As Long: dlRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
    Dim drg As Range: Set drg = ws.Range("I11:I" & dlRow)
    Dim dnCell As Range ' Destination Next Cell
    Set dnCell = ws.Cells(ws.Rows.Count, "I").End(xlUp).Offset(1)
    
    Dim sCell As Range ' Source Cell
    Dim sValue As Variant ' Source Value
    Dim diCell As Range ' Destination Indexed Cell ('n'-th cell of 'drg')
    Dim dIndex As Variant ' Destination Index ('n')
    Dim o As Long ' Offset Counter
    
    If Application.CountA(srg.Offset(, scOffset)) = 0 Then
        MsgBox "Nothing to Add"
    Else
        For Each sCell In srg.Cells
            If sCell.Offset(, scOffset).Value <> 0 Then
                ' Get the row of the match: if no match, then error.
                dIndex = Application.Match(sCell.Value, drg, 0)
                If IsError(dIndex) Then ' source not found in destination
                    dnCell.Value = sCell.Value
                    For o = 0 To oUpper
                        sValue = sCell.Offset(, scOffsets(o))
                        ' Write new values.
                        If IsNumeric(sValue) Then
                            dnCell.Offset(, dcOffsets(o)).Value = sValue
                        End If
                    Next o
                    Set dnCell = dnCell.Offset(1) ' next row
                    Set drg = drg.Resize(drg.Rows.Count + 1) ' include new
                Else ' source found in destination
                    Set diCell = drg.Cells(dIndex)
                    For o = 0 To oUpper
                        sValue = sCell.Offset(, scOffsets(o))
                        ' Add new to old values (sum-up).
                        If IsNumeric(sValue) Then
                            diCell.Offset(, dcOffsets(o)).Value _
                                = diCell.Offset(, dcOffsets(o)).Value _
                                + sValue
                        End If
                    Next o
                End If
            End If
        Next sCell
    End If
            
End Sub

在范围内查找匹配的单元格值，如果未找到匹配项，则粘贴单元格值

Find a matching cell value in a range and paste cell value if no match is found

excel

vba

loops

sum

match

If Exists Then Sum up Else New Entry