How can I find each name in a range and paste a value below?

Question

I'm new to coding and am trying to use vba to search through a range of names and find each name in a different range. After finding that name I need to paste a range value in the next empty cell below. I got it to search the name index range but it doesn't find the matching name in the 2nd range even though it is there. the foundCell range always reads as "Nothing"

Here is the code I have produced so far (with help from google)

Sub pasteDate()
With ActiveSheet
Dim dt As Range
Dim indexName As Range
Dim findRng As Range
Dim foundCell As Range
Set dt = Range("L15")
Set indexName = Range("Z1:AG12")
Set findRng = Range("B3:Y130")<sub>your text</sub>


For Each element In indexName

         Set foundCell = findRng.Find(element.Value)
         
         
      If Not foundCell Is Nothing Then
      
 Range(foundCell & Rows.Count).End(xlUp).Offset(1).Value = dt
 
        End If
    Next element


End With


End Sub

small mock up of my sheet

Answer 1

I've modified your code using the provided mock up data. Please make the necessary adjustments to the code to align it with your actual data.

Sub pasteDate()

    With ActiveSheet
        Dim dt As Range
        Dim indexName As Range
        Dim findRng As Range
        Dim foundCell As Range
        Dim element As Range
        
        ' Constant for the number of rows below the findRng
        Const dataRows = 3 
        
        ' Set the date cell as the target date (I2)
        Set dt = .Range("I2") ' DT value
        
        ' Set the indexName range 
        Set indexName = .Range("H6:K6")
        
        ' Set the findRng to define the data cells only, not the entire area (A2:F2, A6:F6, A10:F10)
        Set findRng = .Range("A2:F2,A6:F6,A10:F10")
        
        ' Loop through each element in the indexName range
        For Each element In indexName

            Set foundCell = findRng.Find(element.Value)
            
            ' Declare variables for the next empty cell and a counter
            Dim nextCell As Range
            Dim r As Integer
            
            If Not foundCell Is Nothing Then
                r = 1
                ' Loop to find the next empty cell within dataRows
                Do While r <= dataRows
                    Set nextCell = foundCell.Offset(r, 0)
                    ' If the next cell is empty, paste the date and exit the loop
                    If IsEmpty(nextCell) Then
                        nextCell = dt
                        Exit Do
                    Else
                        ' If no empty cell is found within dataRows, show a message and exit
                        r = r + 1
                        If r > dataRows Then
                        foundCell.Activate
                        Range(ActiveCell.Offset(2, 0), ActiveCell.Offset(3, 0)).Select
                        Application.CutCopyMode = False
                        Selection.Cut Destination:=foundCell.Offset(1)
                        dt.Copy
                        nextCell.Offset(1) = dt
                        nextCell.Offset(1).Interior.Color = dt.Interior.Color
                            Exit Do 'was Exit For
                        End If
                    End If
                Loop
            End If
        Next element
    End With
End Sub