Question

我正在尝试匹配工作表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

Answer 1

另一种方法是

将resSht初始化为0的第一个
仅循环查看每个ID产品对的dataSht
使用match在resSht上查找ID和产品，并填写1以查找

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

示例结果

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

1 个答案: