excel - Matching range values to worksheet names then finding a cell and copying the value beside it

Question

I have two worksheets

1. Source(ThisWorkbook) - contains multiple worksheets
2. Destination(WBD) - contains 1 worksheet

This is the process:

1. Compare each cell from a range in WBD (B2:B6) to all worksheet names in ThisWorkbook
2. If a match is found, from a range in WBD (C2:C7) and look for it in the matched worksheet
3. (this is where I'm having troubles)How do I get the value of the avg price cell? Do I need another loop?

*the distance between type and price is consistent.

Here's what I got so far:

For Each cel In WBD.Worksheets(1).Range("B2:B6")
    For Each ws In ThisWorkbook.Worksheets
        ws.Activate
            If ws.Name = cel.Value Then
                'find C2:C7 , offset, copy avg price, paste
    Next ws
Next cel

Source - ThisWorkbook

Destination - WBD

question from:https://stackoverflow.com/questions/65931072/matching-range-values-to-worksheet-names-then-finding-a-cell-and-copying-the-val

Answer 1

A Lookup by Worksheets

An Application.Match Approach

Option Explicit

Sub lookupValues()

    Const dFirst As Long = 2
    Const sFirst As Long = 2
    
    Dim swb As Workbook: Set swb = ThisWorkbook
    'Dim WBD As Workbook: Set WBD = ThisWorkbook
    
    Dim drg As Range
    Dim dLast As Long
    With WBD.Worksheets(1)
        dLast = .Cells(.Rows.Count, "C").End(xlUp).Row ' because merged in 'B'
        Set drg = .Cells(dFirst, "B").Resize(dLast - dFirst + 1)
    End With
    
    Dim src As Worksheet
    Dim srg As Range
    Dim cel As Range
    Dim dMatch As Variant
    Dim sMatch As Variant
    Dim sLast As Long
    
    For Each src In swb.Worksheets
        sLast = src.Cells(src.Rows.Count, "C").End(xlUp).Row
        Set srg = Nothing
        On Error Resume Next
        Set srg = src.Cells(sFirst, "B").Resize(sLast - sFirst + 1)
        On Error GoTo 0
        If Not srg Is Nothing Then
            dMatch = Application.Match(src.Name, drg, 0)
            If IsNumeric(dMatch) Then
                Set cel = drg.Cells(dMatch)
                Do
                    sMatch = Application.Match(cel.Offset(, 1).Value, srg, 0)
                    If IsNumeric(sMatch) Then
                        cel.Offset(, 2).Value _
                            = srg.Cells(sMatch).Offset(3, 2).Value
                    End If
                    Set cel = cel.Offset(, 1).Offset(1, -1) ' because merged
                Loop Until Len(cel.Value) > 0 Or cel.Row > dLast
            End If
        End If
    Next src
    
    'WBD.Save
    'swb.Close SaveChanges:=False
    
End Sub