如何使用VBA匹配两张纸上的两组单元格

第83章

我正在尝试将工作表1中的ID单元格与工作表2中的ID单元格匹配。如果这些匹配，则需要将工作表1中的产品单元格与工作表2中的产品单元格进行匹配。

工作表1中的ID单元格在同一列中具有相同的ID的倍数，在下一单元格中具有不同的乘积（列A = ID，列B =乘积）。

在工作表2中，每个ID只有一个实例，但是产品横穿该行。如果两个条件匹配，则需要1在产品下方的单元格中放置一个。

这需要在行中循环，当行结束时，移至工作表1中的下一个ID。如果条件不匹配，则需要用填充单元格0。

我遇到的麻烦是转移到下一个ID。我已包含代码，感谢您的帮助。

Public Sub test()
    Dim ws As Worksheet, sh As Worksheet
    Dim wsRws As Long, dataWsRws As Long, dataRng As Range, data_Rng As Range, data_cell As Range, datacell As Range
    Dim shRws As Long, prodShRws As Long, resRng As Range, res_Rng As Range, results_cell As Range, product_cell As Range, shCols As Long

    Set dataSht = Sheets("Device Import")
    Set resSht = Sheets("Transform Pivot")

    With dataSht
        wsRws = .Cells(.Rows.Count, "A").End(xlUp).Row
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        dataWsRws = .Cells(.Rows.Count, "B").End(xlUp).Row
        Set dataRng = .Range(.Cells(2, "A"), .Cells(wsRws, "A"))
        Set data_Rng = .Range(.Cells(2, "B"), .Cells(wsRws, "B"))
    End With

    With resSht
        shRws = .Cells(Rows.Count, "A").End(xlUp).Row
        shCols = .Cells(1, Columns.Count).End(xlToLeft).Column
        Set resRng = .Range(.Cells(2, "A"), .Cells(shRws, "A"))
        Set res_Rng = .Range(.Cells(1, "B"), .Cells(1, shCols))
    End With
    i = 1
    For Each data_cell In dataRng   'data sheet
        For Each product_cell In res_Rng    'results sheet
            For Each datacell In data_Rng   'data sheet
                    For Each results_cell In resRng 'results range
                        If data_cell = results_cell And datacell = product_cell Then
                            MsgBox data_cell.Value + " " + datacell.Value
                            results_cell.Offset(0, i) = 1   ' dcell = rcell so recell offset = 1
                        Else
                            MsgBox product_cell.Value + " " + results_cell.Value
                            results_cell.Offset(0, i) = 0   ' no match so rcell offset = 0
                        End If

                        If results_cell = "" Then
                            Exit For
                        End If
                        i = i + 1
                    Next results_cell ' Results ID column
                i = 1
                Exit For
            Next datacell  ' Data Product column cell
        Next product_cell ' Results ID row
    Next data_cell ' Data ID column cell
End Sub

克里斯·尼尔森

另一种方法是

初始化resSht到0的第一个
仅循环dataSht查看每个ID产品对
使用match发现的ID和产品resSht并填充1的为FOUND

Public Sub Demo()
    Dim dataSht As Worksheet, resSht As Worksheet
    Dim rData As Range
    Dim rwRes As Variant, clRes As Variant
    Dim colResID As Long, rwResProd As Long

    colResID = 1 '<-- Column in Result Sheet containing ID
    rwResProd = 1 '<-- Row in Result Sheet containing Products

    Set dataSht = Sheets("Device Import")
    Set resSht = Sheets("Transform Pivot")

    'Initialise to 0
    With resSht
        .Range(.Cells(rwResProd, .Columns.Count).End(xlToLeft).Offset(1, 0), _
          .Cells(.Rows.Count, colResID).End(xlUp).Offset(0, 1)) = 0
    End With

    ' Lookup each ID and Product pair from dataSht in resSht
    With dataSht
        For Each rData In .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
            rwRes = Application.Match(rData.Value2, resSht.Columns(colResID), 0)
            If Not IsError(rwRes) Then
                clRes = Application.Match(rData.Offset(0, 1).Value2, resSht.Rows(rwResProd), 0)
                If Not IsError(clRes) Then
                    resSht.Cells(rwRes, clRes) = 1
                Else
                    MsgBox "Product " & rData.Offset(0, 1).Value2 & " not found in Result Sheet", vbOKOnly + vbExclamation, "Missing Product"
                End If
            Else
                MsgBox "ID " & rData.Value2 & " not found in Result Sheet", vbOKOnly + vbExclamation, "Missing ID"
            End If
        Next
    End With
End Sub

结果示例