CODEWITHSUNDEEP
vbaexcel
TheRunner83
TheRunner83

Reputation: 41

How to match two sets of cells on two sheets using vba

I am trying to match an ID cell from sheet 1 to and ID cell in sheet 2. If these match then I need to match a product cell from sheet 1 to a product cell in sheet two.

The ID cell in sheet 1 has multiples of the same ID in a column with different products in the next cell (column A = ID, column B = product).

In sheet 2 there is only one instance of each ID, however the product goes across the row. If the two criteria match, I need a 1 to be placed in the cell below the product.

This needs to be looped across the row and once the row finishes, move to the next ID in sheet 1. If the criteria do not match then the cell needs to be filled with a 0.

The trouble I am have is moving to the next ID. I have included the code and appreciate any help.

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

Upvotes: 1

Views: 123

Answers (1)

chris neilsen
chris neilsen

Reputation: 53136

An alternative approach would be

  1. Initialize the resSht to 0's first
  2. Loop only the dataSht looking at each ID Product pair
  3. Use match to find the ID and product on resSht and fill in 1's as 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

Example Result

Example Result

Upvotes: 1

Related Questions