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