Find value into another sheet to fill a table - excel

Question

I have two sheets and I need to get names of fields for each person. For that I need to take a person of a row in sheet2 then i have to get the fields which this person is assigned in the sheet1 on the right table (for every rows). For this part I found and modified this VBA code, but it doesn't do what I need ... :
Dim rgFound As Range
Dim defVal As Range
Dim currParam As Range
Dim currParamDict As Range
With Worksheets("Sheet2")
For Each defVal In .Range("B3", .Range("B" & Rows.Count).End(xlUp)).Offset(, 1)
Set currParam = defVal.Offset(, -1)
If Len(currParam.Value) > 0 Then
Set rgFound = Worksheets("Sheet1").Range("F9:I12").Find(currParam.Value)
If rgFound Is Nothing Then
Debug.Print "Name was not found."
Else
Set currParamDict = rgFound.Offset(, 0)
defVal.Value = currParamDict.Value
End If
End If
Next defVal
End With
I dont know for the range in : Set rgFound = Worksheets("Sheet1").Range("F9:I12").Find(currParam.Value)
I put some example pictures so you can see what it is about.
Sheet1 :
Sheet2 :
After this step, I have to fill the dates corresponding to fields using the left table of the Sheet1...

Answer 1

Fill a Table
Off Track
Ignore possible old data in Sheet2 and write the complete table.
Option Explicit
Sub FillTable()
' Source Dates
Const sdName As String = "Sheet1"
Const sdFirst As String = "B2"
' Source Cities
Const scName As String = "Sheet1"
Const scFirst As String = "F9"
' Destination
Const dName As String = "Sheet2"
Const dFirst As String = "B2"
Const dHeader As String = "Name"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source Dates
Dim sdws As Worksheet: Set sdws = wb.Worksheets(sdName)
Dim sdrg As Range: Set sdrg = sdws.Range(sdFirst).CurrentRegion
Dim sdData As Variant: sdData = sdrg.Value
Dim sdrCount As Long: sdrCount = sdrg.Rows.Count
Dim sdcCount As Long: sdcCount = sdrg.Columns.Count
' Source Cities
Dim scws As Worksheet: Set scws = wb.Worksheets(scName)
Dim scrg As Range: Set scrg = scws.Range(scFirst).CurrentRegion
Dim scData As Variant: scData = scrg.Value
Dim schrg As Range: Set schrg = scrg.Rows(1)
Dim scrCount As Long: scrCount = scrg.Rows.Count
Dim sctCount As Long: sctCount = Application.CountA(scrg)
' Destination Array
Dim drCount As Long: drCount = sctCount + 1 ' '+ 1' for headers
Dim dcCount As Long: dcCount = 1 + sdcCount ' 1 for 'Name'
Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
' Write headers to Destination Array.
Dim sdc As Long
dData(1, 1) = dHeader
For sdc = 1 To sdcCount
dData(1, sdc + 1) = sdData(1, sdc)
Next sdc
' Write 'body' to Destination Array.
Dim dr As Long: dr = 1 ' 1 for headers
Dim sccIndex As Variant
Dim scValue As Variant
Dim sdr As Long
Dim scr As Long
For sdr = 2 To sdrCount
sccIndex = Application.Match(sdData(sdr, 1), schrg, 0)
For scr = 2 To scrCount
scValue = scData(scr, sccIndex)
If Not IsError(scValue) Then
If Len(scValue) > 0 Then
dr = dr + 1
dData(dr, 1) = scValue
For sdc = 1 To sdcCount
dData(dr, sdc + 1) = sdData(sdr, sdc)
Next sdc
End If
End If
Next scr
Next sdr
' Write Destination Array to Destination Range.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfcell As Range: Set dfcell = dws.Range(dFirst)
Dim drg As Range: Set drg = dfcell.Resize(drCount, dcCount)
drg.Value = dData
' Clear Destination Clear Range, the range below Destination Range.
Dim dcrg As Range
Set dcrg = drg.Resize(drg.Worksheet.Rows.Count - drg.Row - drCount + 1) _
.Offset(drCount)
dcrg.Clear ' or 'dcrg.ClearContents'
' Format e.g.:
drg.Rows(1).Font.Bold = True
dws.Range(drg.Columns(3), drg.Columns(dcCount)).Resize(drCount - 1) _
.Offset(1).NumberFormat = "dd/mm/yyyy" ' possibly "dd\/mm\/yyyy"
drg.EntireColumn.AutoFit
'wb.Save
End Sub
Meeting the Requirement
There are the names in Sheet2, so fill the other columns.
Sub FillTable2()
' Source Dates
Const sdName As String = "Sheet1"
Const sdFirst As String = "B2"
' Source Cities
Const scName As String = "Sheet1"
Const scFirst As String = "F9"
' Destination
Const dName As String = "Sheet2"
Const dFirst As String = "B2"
Dim wb As Workbook: Set wb = ThisWorkbook
' Source Dates
Dim sdws As Worksheet: Set sdws = wb.Worksheets(sdName)
Dim sdrg As Range: Set sdrg = sdws.Range(sdFirst).CurrentRegion
Dim sddrg As Range: Set sddrg = sdrg.Resize(sdrg.Rows.Count - 1).Offset(1)
Dim sdData As Variant: sdData = sddrg.Value
Dim sdrlrg As Range: Set sdrlrg = sddrg.Columns(1) ' Row Labels
' Source Cities
Dim scws As Worksheet: Set scws = wb.Worksheets(scName)
Dim scrg As Range: Set scrg = scws.Range(scFirst).CurrentRegion
Dim schRow As Long: schRow = scrg.Row ' Header Row
Dim scdrg As Range: Set scdrg = scrg.Resize(scrg.Rows.Count - 1).Offset(1)
Dim scrCount As Long: scrCount = scdrg.Rows.Count
Dim sccCount As Long: sccCount = scdrg.Columns.Count
' Destination Names
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfcell As Range: Set dfcell = dws.Range(dFirst)
Dim drg As Range: Set drg = dfcell.CurrentRegion.Columns(1)
Dim dnrg As Range: Set dnrg = drg.Resize(drg.Rows.Count - 1).Offset(1)
Dim dnData As Variant: dnData = dnrg.Value
' Destination Array
Dim drCount As Long: drCount = dnrg.Rows.Count
Dim dcCount As Long: dcCount = sdrg.Columns.Count
Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
Dim scCell As Range
Dim dnValue As Variant
Dim scValue As Variant
Dim sdrIndex As Variant
Dim r As Long
Dim c As Long
For r = 1 To drCount
dnValue = dnData(r, 1)
If NoErrorNorBlank(dnValue) Then
Set scCell = Nothing
Set scCell = scdrg.Find(dnValue, _
scdrg.Cells(scrCount, sccCount), xlFormulas, xlWhole)
If Not scCell Is Nothing Then
scValue = scCell.EntireColumn.Rows(schRow).Value
If NoErrorNorBlank(scValue) Then
sdrIndex = Application.Match(scValue, sdrlrg, 0)
If IsNumeric(sdrIndex) Then
For c = 1 To dcCount
dData(r, c) = sdData(sdrIndex, c)
Next c
End If
End If
End If
End If
Next r
Set drg = dnrg.Offset(, 1).Resize(, dcCount)
drg.Value = dData
'wb.Save
End Sub
Function NoErrorNorBlank( _
ByVal CheckValue As Variant) _
As Boolean
If Not IsError(CheckValue) Then
If Len(CheckValue) > 0 Then
NoErrorNorBlank = True
End If
End If
End Function

Answer 2

This line is not identifying a district, but the name in the search itself. Change the statement to reference the data in line 9. I assume that position is fixed, if not then you need another approach.
Set currParamDict = rgFound.Offset(, 0)
' becomes
set currParamDict = Worksheets("sheet1").Cells(9, rgFound.Column)