Copy Values With Lookups

[Bob81773]

I have a small section in a workbook that is used for calculating various statistics for an individual based on other input. Essentially, the results look something like this:
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Today's Date[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Individual[/TD]
[TD]Stat One[/TD]
[TD]Stat Two[/TD]
[TD]Stat Three[/TD]
[/TR]
[TR]
[TD]Peter[/TD]
[TD]14[/TD]
[TD]23[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]John[/TD]
[TD]3[/TD]
[TD]21[/TD]
[TD]5[/TD]
[/TR]
[TR]
[TD]Jim[/TD]
[TD]21[/TD]
[TD]14[/TD]
[TD]15[/TD]
[/TR]
</tbody>[/TABLE]


From this sheet, I'd like to take the results and copy the values to three different sheets that contain many more individuals -- by finding the individual's name and date, then copying the value. One sheet, for the first statistic, looks like this:

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Individual[/TD]
[TD]Date1[/TD]
[TD]Date2[/TD]
[TD]Date3[/TD]
[TD]...[/TD]
[/TR]
[TR]
[TD]Ralph[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Peter[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Nancy[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Ernest[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Frank[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]John[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Paul[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Simon[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Jim[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Jean[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Rich[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


Hopefully, I could do this with VBA and, once the calculations are completed in the small section above, just run the code and copy the results so that new calculations could be done for different individuals.
I'm having a little trouble coming up with this VBA routine. Any help would be appreciated. Thanks.

 

[dhancy]

Try something like this:

Sub aaa()
Dim ws1 As Worksheet
Dim wsStat As Worksheet
Dim r As Integer
Dim c As Integer
Dim rStat As Integer
Dim cStat As Integer
Dim dt As String
Dim name As String
Dim wsname As String
r = 3   ' First row in sheet1 to contain a person's name
c = 2   ' Column in Sheet1 containing stat information to read from
Set ws1 = Sheets("Sheet1")
wsname = ws1.Cells(2, c)
Set wsStat = Sheets(wsname)
dt = ws1.Cells(1, 2)
Do While ws1.Cells(r, 1) <> ""
    name = ws1.Cells(r, 1)
    Set x = wsStat.Rows("1:1").Find(dt, LookIn:=xlValues)
    If Not x Is Nothing Then
        cStat = x.Column
        Set x = wsStat.Columns("A:A").Find(name, LookIn:=xlValues)
        If Not x Is Nothing Then
            rStat = x.Row
            wsStat.Cells(rStat, cStat) = ws1.Cells(r, c)
        End If
    End If
    r = r + 1
Loop
            
End Sub

A few notes:

1) Set the value of "C" to the stat column in your first worksheet where you want to copy from (I'm guessing you want to add a loop on this somewhere to go through all the stat columns)
2) Also, I'm having issues with .find on the date value (the second statement starting with "Set x"). .find works great on string values. Just can't seem to get it to work with date values though. That part still needs more research.

 

[dhancy]

Eureka!! Thanks to Joe4, here is the updated code that fixed the "find date" problem. Thank you Joe4!

Sub aaa()
Dim ws1 As Worksheet
Dim wsStat As Worksheet
Dim r As Integer
Dim c As Integer
Dim rStat As Integer
Dim cStat As Integer
Dim dt As String
Dim name As String
Dim wsname As String
r = 3   ' First row in sheet1 to contain a person's name
c = 2   ' Column in Sheet1 containing stat information to read from
Set ws1 = Sheets("Sheet1")
wsname = ws1.Cells(2, c)
Set wsStat = Sheets(wsname)
dt = DateValue(ws1.Cells(1, 2))
Do While ws1.Cells(r, 1) <> ""
    name = ws1.Cells(r, 1)
    Set x = wsStat.Rows("1:1").Find(dt, LookIn:=xlFormulas)
    If Not x Is Nothing Then
        cStat = x.Column
        Set x = wsStat.Columns("A:A").Find(name, LookIn:=xlValues)
        If Not x Is Nothing Then
            rStat = x.Row
            wsStat.Cells(rStat, cStat) = ws1.Cells(r, c)
        End If
    End If
    r = r + 1
Loop
            
End Sub

 

[Bob81773]

This was extremely helpful. Thanks, dhancy and Joe4 for the help and insight. Much appreciated!