Excelsearch数组从数据validation中匹配值，然后在相邻单元格中进行计算

我有单元格H7中的数据validation，您可以select一个部分，并在单元格I7数量删除数据validation（1,2,3,4,5等）。 我需要的macros是从数组D7：D12中的单元格H7中find匹配的文本，然后从E7：E12中减去从I7中select的数量与H7中select的相同部分。

我已经尝试了很多东西，但我似乎能够得到的是突出显示find的文本

Sub CompareAndHighlight() Dim rng1 As Range, rng2 As Range, i As Long, j As Long For i = 1 To Sheets("Sheet1").Range("D" & Rows.Count).End(xlUp).Row Set rng1 = Sheets("Sheet1").Range("D" & i) For j = 1 To Sheets("Sheet1").Range("H7").End(xlUp).Row Set rng2 = Sheets("Sheet1").Range("H7") If StrComp(Trim(rng1.Text), Trim(rng2.Text), vbTextCompare) = 0 Then rng1.Interior.Color = RGB(255, 255, 0) End If Set rng2 = Nothing Next j Set rng1 = Nothing Next i End Sub 

Answer 1

 Sub CompareAndHighlight() Dim rng1 As Range, i As Long For i = 1 To Sheets("Sheet1").Range("D" & Rows.Count).End(xlUp).Row Set rng1 = Sheets("Sheet1").Range("D" & i) If StrComp(Trim(rng1.Text), Trim(Sheets("Sheet1").Range("H7").Text), vbTextCompare) = 0 Then rng1.Interior.Color = RGB(255, 255, 0) 'Reduce quantity by quantity selected rng1.Offset(0, 1).Value = rng1.Offset(0, 1).Value - Sheets("Sheet1").Range("I7").Value End If Set rng1 = Nothing Next i End Sub 

---

该版本将处理H：I中的多个input值，从第7行开始：

 Sub UpdateInventory() Dim rNew As Long 'Row of new items Dim rTable As Long 'Row within main table Dim partNo As Variant 'To store part number being processed Dim qty As Variant 'To store new quantity With Worksheets("Sheet1") 'Uncomment the following line if you want to clear out cell colouring 'in column "D" so that it is easier to see which rows have been 'affected by running this macro '.Columns("D").Interior.Color = xlNone For rNew = 7 To .Range("H" & .Rows.Count).End(xlUp).Row partNo = Trim(.Cells(rNew, "H").Text) qty = .Cells(rNew, "I").Value For rTable = 1 To .Range("D" & .Rows.Count).End(xlUp).Row If StrComp(Trim(.Cells(rTable, "D").Text), partNo, vbTextCompare) = 0 Then 'Highlight cell to show that change has occurred? .Cells(rTable, "D").Interior.Color = RGB(255, 255, 0) 'Reduce quantity by quantity selected .Cells(rTable, "E").Value = .Cells(rTable, "E").Value - qty Exit For End If Next Next End With End Sub 

注意：内部循环可以用Find来代替。 如果你有很多的数据，那会更有效率。 如果你没有太多的数据（例如超过几百行），我的首选是继续使用循环。

---

要使用不同的工作表下拉列表和股票列表，我会使用以下内容：

 Option Explicit Sub UpdateInventory() Dim wsJobCard As Worksheet Dim r1JobCard As Long Dim rJobCard As Long Dim colPartNoJobCard As String Dim colQtyJobCard As String Dim wsPartsList As Worksheet Dim r1PartsList As Long Dim rPartsList As Long Dim colPartNoPartsList As String Dim colQtyPartsList As String Dim partNo As Variant Dim qty As Variant Set wsJobCard = Worksheets("Job_Card") Set wsPartsList = Worksheets("Parts_List") 'Adjust these to show which columns are being used on the two sheets colPartNoJobCard = "G" '???? colQtyJobCard = "H" '???? colPartNoPartsList = "B" colQtyPartsList = "C" 'Adjust these to show which row is the start of data on each sheet r1JobCard = 67 r1PartsList = 2 With wsPartsList 'Uncomment the following line if you want to clear out previous 'cell colouring so that it is easier to see which rows have been 'affected by running this macro '.Columns(colPartNoPartsList).Interior.Color = xlNone For rJobCard = r1JobCard To wsJobCard.Range(colPartNoJobCard & wsJobCard.Rows.Count).End(xlUp).Row partNo = Trim(wsJobCard.Cells(rJobCard, colPartNoJobCard).Text) qty = wsJobCard.Cells(rJobCard, colQtyJobCard).Value For rPartsList = 1 To .Range(colPartNoPartsList & .Rows.Count).End(xlUp).Row If StrComp(Trim(.Cells(rPartsList, colPartNoPartsList).Text), partNo, vbTextCompare) = 0 Then 'Highlight cell to show that change has occurred? .Cells(rPartsList, colPartNoPartsList).Interior.Color = RGB(255, 255, 0) 'Reduce quantity by quantity selected .Cells(rPartsList, colQtyPartsList).Value = .Cells(rPartsList, colQtyPartsList).Value - qty Exit For End If Next Next End With End Sub