查找并返回另一个单元格值，其间有单元格间隙

问题描述

我基本上被困在这个 VBA 中，因为我不知道如何查找 2 个单元格并返回另一个单元格值。可能可以通过读取项目名称先查找然后读取周数以匹配并返回灰色区域中的相位来解决，但是将2查找放在一起对我来说很困难。

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.

解决方法

使用几个 Dictionary Objects 作为对 Project 行和 Week 列的查找。

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,"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",_
                        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",_
                                   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