VBA - 將兩列中的單元格與其他兩列中的單元格進行比較

Question

我已經搜索了很多且未找到此問題的良好答案。

我有兩個列表，每列兩列。清單包含經銷商編號（A欄）和經銷商的零件編號（B欄）。相同的值可能會在每列中出現重複（每個經銷商有幾個零件號碼，每個零件號碼可能會出現在幾個經銷商處）。

我希望腳本用A1和B1在Sheet開始，檢查是否兩個細胞具有Sheet 2中的匹配 - 列A和列B中，如果是標記在A1爲紅色的等效電池，然後移動到A2 + B2再次進行相同的比較。換句話說，它應該檢查第1頁中的第1行，將其與Sheet2中的每一行進行比較以匹配，如果存在匹配，則將Sheet1中的A單元格標記爲紅色，然後移至Sheet1中的下一行。

這裏是我遇到問題的地方;我似乎無法使腳本變​​得靈活。我的腳本似乎沒有檢查Sheet1中的單元格A和B，也沒有檢查每個循環的表格2中的全部範圍。

在接下來的步驟中，我還希望腳本檢查Sheet2中的第三列是否高於Sheet1中的相應單元格，但是我應該能夠處理該基礎知識。

這裏是我的代碼現在的樣子：

Sub Comparestwocolumns() 

Dim i As Long 
Dim lastrow As Long 
Dim ws As Worksheet 

Set ws = Sheet1 
Set ws2 = Sheet2 

For i = 1 To 500000 

If IsEmpty(ws.Range("A" & i)) = True Then 
    Exit For 
End If 
For j = 1 To 500000 

If IsEmpty(ws2.Range("A" & j)) = True Then 
     Exit For 
     End If 


If ws.Range("A" & i).Value = ws2.Range("A" & j).Value Then 

If ws.Range("A" & i).Offset(0, 1).Value = ws2.Range("A" & j).Offset(0, 1).Value Then 

       ws.Range("A" & i).Interior.Color = vbRed 
      Else 

       ws.Range("A" & i).Interior.Color = vbWhite 

      End If 

      Exit For 
      End If 

Next j 
Next i 
MsgBox ("Finished ") 
End Sub 

謝謝！

Answer 1

關閉，太近了。

我對你的代碼所做的大部分修改都是「修飾」（例如使用「B」而不是從「A」中偏移一列）。

主更改是If聲明。經過「美容」的變化，你的If聲明結束了看起來像：

If ws.Range("A" & i).Value = ws2.Range("A" & j).Value Then 
    If ws.Range("B" & i).Value = ws2.Range("B" & j).Value Then 
     ws.Range("A" & i).Interior.Color = vbRed 
    End If 
    Exit For 
End If 

的問題是，一旦退出For j環路在列中的值匹配，即使在B列沒了值」 t匹配。只有在列A和列B匹配時才需要執行Exit For，例如，

If ws.Range("A" & i).Value = ws2.Range("A" & j).Value Then 
    If ws.Range("B" & i).Value = ws2.Range("B" & j).Value Then 
     ws.Range("A" & i).Interior.Color = vbRed 
     Exit For 
    End If 
End If 

---

最後的代碼，我所有的更改之後，最終爲：

Sub Comparestwocolumns() 

    Dim i As Long 
    Dim j As Long 
    Dim lastrow As Long 
    Dim ws As Worksheet 

    Set ws = Sheet1 
    Set ws2 = Sheet2 

    For i = 1 To 500000 
     If IsEmpty(ws.Range("A" & i)) Then 
      Exit For 
     End If 

     For j = 1 To 500000 
      If IsEmpty(ws2.Range("A" & j)) Then 
       Exit For 
      End If 

      If ws.Range("A" & i).Value = ws2.Range("A" & j).Value Then 
       If ws.Range("B" & i).Value = ws2.Range("B" & j).Value Then 
        ws.Range("A" & i).Interior.Color = vbRed 
        Exit For 
       End If 
      End If 
     Next j 
    Next i 
    MsgBox ("Finished ") 
End Sub 

Answer 2

循環，直到你有你的表數據：

Option Explicit 
Sub matcher() 

    Dim i As Integer, j As Integer 

    i = 1 
    While Sheets(1).Cells(i, 1).Value <> "" 
     j = 1 
     While Sheets(2).Cells(j, 1).Value <> "" 

      If Sheets(1).Cells(i, 1).Value = Sheets(2).Cells(j, 1).Value And Sheets(1).Cells(i, 2).Value = Sheets(2).Cells(j, 2).Value Then 
       Sheets(1).Cells(i, 1).Interior.ColorIndex = 3 
      End If 

      j = j + 1 
     Wend 
     i = i + 1 
    Wend 
End Sub 

Answer 3

可以使用AutoFilter（）：

Option Explicit 

Sub Comparestwocolumns() 
    Dim firstShtRng As Range, filteredRng As Range, colorRng As Range, cell As Range 

    With Worksheets("Sheet2") '<--| reference your 2nd sheet 
     Set firstShtRng = .Range("A1", .cells(.Rows.Count, 1).End(xlUp)) '<--| gather its column A values from row 1 down to last not empty row to be checked in 2nd sheet 
    End With 

    With Sheets("Sheet1") '<--| reference your 1st sheet 
     With .Range("A1", .cells(.Rows.Count, 1).End(xlUp)) '<--| reference its column A range from row 1 down to last not empty row 
      .AutoFilter Field:=1, Criteria1:=Application.Transpose(firstShtRng.Value), Operator:=xlFilterValues '<--| filter referenced cells with 'firstShtRng' values 
      Set filteredRng = .SpecialCells(xlCellTypeVisible) '<--| set filtered cells to 'filteredRng' range 
      Set colorRng = .Offset(, 1).Resize(1, 1) '<--| initialize 'colorRng' to a "dummy" cell that's out of range of interest: it'll be used to avoid subsequent checking against "nothing" before calling 'Union()' method and eventually discharged 
     End With 
     .AutoFilterMode = False 
    End With 

    For Each cell In filteredRng '<--| loop through filtered cells in "Sheet1" 
     If firstShtRng.Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole).Offset(, 1) = cell.Offset(, 1) Then Set colorRng = Union(colorRng, cell) '<--| if current cell adjacent value matches corresponding value in "Sheet2" then update 'colorRng' 
    Next 
    Set colorRng = Intersect(filteredRng, colorRng) '<--| get rid of "dummy" cell 
    If Not colorRng Is Nothing Then colorRng.Interior.Color = vbRed '<--| if any survived cell in "Sheet1" then delete corresponding rows 
End Sub