我試圖遍歷一個名為的范圍，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
uj5u.com熱心網友回復：
如果存在則總結其他新條目
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
轉載請註明出處，本文鏈接：https://www.uj5u.com/qianduan/383980.html
上一篇：ExcelVSTO單元格精度