在范圍內查找匹配的單元格值，如果未找到匹配項，則粘貼單元格值

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

如果存在則總結 Else 新條目

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