Excel搜索数组中匹配数据验证的值，然后在相邻单元格中进行计算

Question

我在单元格H7中有一个数据验证，您可以在其中选择一个零件并在单元格I7中删除一个数量验证（1,2,3 ，4,5等）。我需要的宏是从数组D7中的单元格H7中找到匹配的文本：D12，然后从E7中减去从I7中选择的数量：E12为与H7一起选择的相同部分。

我已经尝试了很多事情，但我似乎能够得到突出显示的发现文本

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，从第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