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
CodePudding user response:
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