Lookup and return another cell value with a gap of cell in between

Question

I am basically stuck in this VBA as I did not know how to lookup 2 cells and return with another cell value. It might be solve with reading project name to lookup first and then reading the week number to match and return the phase in grey area, but to get the 2 lookup together is difficult for me.

This is the first sheet where the input come in as week number and date in each phase

The second sheet will search the project number and week number, return the phase in column J and next.

Answer 1

Use a couple of Dictionary Objects as look-ups to the Project rows and Week columns.

Option Explicit

Sub Macro()

    Const SHT_PRJ = "Project"
    Const COL_ID_PRJ = "E"
    Const COL_PH1 = "F" ' Phase 1
    Const ROW_HDR_PRJ = 2 ' header

    Const SHT_DEM = "Demand"
    Const COL_ID_DEM = "D"
    Const ROW_HDR_DEM = 1
    Const MAX_PH = 6 ' phases 1 to 6

    Dim wb As Workbook
    Dim wsIn As Worksheet, wsOut As Worksheet
    Dim cell As Range, rng As Range
    Dim iRow As Long, iLastRow As Long, iCol() As Integer, iLastCol As Integer
    Dim iColWk As Integer
    Dim iColor As Variant, sWk As String, iPh As Integer

    Set wb = ThisWorkbook
    Set wsIn = wb.Sheets(SHT_PRJ)

    Dim dict As Object, dictWk As Object, key
    Set dict = CreateObject("Scripting.Dictionary")
    Set dictWk = CreateObject("Scripting.Dictionary")

    ' build lookup to row for ID
    iLastRow = wsIn.Cells(Rows.Count, COL_ID_PRJ).End(xlUp).Row
    For iRow = ROW_HDR_PRJ + 1 To iLastRow
        key = Trim(wsIn.Cells(iRow, COL_ID_PRJ))
        If dict.exists(key) Then
            MsgBox "Duplicate key " & key, vbCritical, "Row " & iRow
            Exit Sub
        ElseIf Len(key) > 0 Then
            dict.Add key, iRow
        End If
    Next

    ' build look up to column for week
    Set wsOut = wb.Sheets(SHT_DEM)
    iLastCol = wsOut.Cells(ROW_HDR_DEM, Columns.Count).End(xlToLeft).Column
    For Each cell In wsOut.Cells(ROW_HDR_DEM, 1).Resize(1, iLastCol)
        key = Trim(cell.Value)
        If dictWk.exists(key) Then
            MsgBox "Duplicate week " & key, vbCritical, "Col " & cell.Column
            Exit Sub
        ElseIf Len(key) > 0 Then
            dictWk.Add key, cell.Column
        End If
    Next

     ' update demand sheet
    ReDim iCol(MAX_PH)
    iLastRow = wsOut.Cells(Rows.Count, COL_ID_DEM).End(xlUp).Row
    For Each cell In wsOut.Cells(ROW_HDR_DEM + 1, COL_ID_DEM).Resize(iLastRow)
        iColor = cell.Interior.ColorIndex
        key = Trim(cell.Value)
        ' each project
        If Len(key) > 0 And iColor <> xlColorIndexNone Then '-4142
            
            iRow = dict(key) ' row on project sheet
            If iRow < 1 Then
                 MsgBox "ID " & key & " not found", vbCritical, _
                        wsOut.Name & " Row " & cell.Row
                 Exit Sub
            Else
                
                ' get week numbers for each phase
                For iPh = 1 To MAX_PH
                    sWk = wsIn.Cells(iRow, COL_PH1).Offset(0, 2 * (iPh - 1))
                    If Len(sWk) > 0 Then
                        ' look up week to column
                        iCol(iPh) = dictWk(sWk)
                        If iCol(iPh) < 1 Then
                            MsgBox "Week " & sWk & " not found", vbCritical, _
                                   wsOut.Name & " Row " & cell.Row
                            Exit Sub
                        Else
                            ' update sheet
                            wsOut.Cells(cell.Row, iCol(iPh)) = "Phase " & iPh
                        End If
                     End If
                Next
               
                ' fill in gaps with previous
                For iColWk = iCol(1) To iCol(MAX_PH)
                   Set rng = wsOut.Cells(cell.Row, iColWk)
                   If rng.Value = "" Then
                       rng.Value = rng.Offset(0, -1).Value
                   End If
                Next
            End If
        End If
    Next

    MsgBox dict.Count & " projects processed"

End Sub