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

user_17620950 0
Viewed 62

I am trying to loop through a range titled mineral and find a matching cell within a separate list titled compList only if a certain range of cells contains a numeric value. If no match is found, then the cell (a string) is copied and pasted into the next available row within compList along with the adjacent cells (numbers). If a match is found, then only the adjacent cells would be added to the existing cells.

This is what I managed to do thus far, it would paste the cell value and adjacent cells as expected, but it would continue to paste these cells even if it already exists in compList. I was not able to create a code to add those values to an existing match since I was trying to figure out this issue.

If you can, please add a brief comment line so I can learn!

Thanks in advance.

        
        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
match vba excel sum loops
1 Answers

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
user_98140690
Related