Find value into another sheet to fill a table

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...

user_16708107 · Answer

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)

user_9814069 · Answer

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

Find value into another sheet to fill a table

2 Answers

Fill a Table