lookup and paste issue with loop

[pankaj8219]

Hi Experts...
i am facing hard to lookup array and need your help....description is below and data you can find in attached workbook

As Is Scenario

If user input “X” in relationship table in “relation” tab, and click on “cmd1” then the “prcode” of “aaa3” (D5) will be insert into same row of “aaa1” (A8) in the “load” tab under column AV.

To Be Scenario

• If user input “X” in multiple column but same row in “relation” tab…then values should be comma separated in load tab (column AV)

• If user input “X” in multiple rows and multiple columns in “relation” tab…then values should be send to relevant cell in load tab (column AV)


current code

Sub Related_to()
     Dim r As Integer
     Dim cell As Range
     r = 2
     Sheets("relation").Select
     For Each cell In Range("B8:AE500")
         If cell.Value = "X" Then
              Cells(5, cell.Column).Copy
                findmatch (Selection)
                'ActiveSheet.Paste
             If cell.Value = "X" Then
                findmatch1 (product1)
                ActiveSheet.Cells(ActiveCell.Row, 48).Select
                ActiveCell.Value = Application.WorksheetFunction.VLookup(Sheets("load").Cells(ActiveCell.Row, 55).Value, Sheets("define").Range("C13:E21"), 3, False)
                ActiveCell.Value = ActiveCell.Value
                Cells(r, 55).Value = ""
                Cells(r, 54).Value = ""
                Cells(r, 53).Value = ""
                r = r + 1
              
              Sheets("relation").Select
             End If
         End If
     Next cell
        Sheets("load").Select
        With Sheets("load")
        Range("BC:BC").Clear
        End With
     Application.CutCopyMode = False
     Application.ScreenUpdating = True
     Sheets("load").Select
 End Sub

Function findmatch(product As String) As String
    If Len(product) > 0 Then
        Worksheets("load").Activate
        Columns("C:C").Select
            Selection.Find(What:=product, After:=ActiveCell, LookIn:=xlValues, LookAt _
            :=xlWhole, SearchOrder:=xlByRows, MatchCase:= _
            False, SearchFormat:=False).Activate
        ActiveCell.Offset(0, 51).Range("A1").Select
        Matchingproduct = ActiveCell.Value
    End If
End Function


Sub findmatch1(product1 As String)
     Dim cell As Range
     Sheets("relation").Select
     For Each cell In Range("B8:AE100")
         If cell.Value = "X" Then
              product1 = Cells(cell.Row, 1).Value
         End If
     Next cell
    If Len(product1) > 0 Then
        Worksheets("load").Activate
        Columns("C:C").Select
            Selection.Find(What:=product1, After:=ActiveCell, LookIn:=xlValues, LookAt _
            :=xlWhole, SearchOrder:=xlByRows, MatchCase:= _
            False, SearchFormat:=False).Activate
        ActiveCell.Offset(0, 52).Range("A1").Select
        ActiveSheet.Paste
        Matchingproduct1 = ActiveCell.Value
    End If
End Sub