查找和 return 之间有一个单元格间隙的另一个单元格值

Question

我基本上陷入了这个 VBA 因为我不知道如何查找 2 个单元格和 return 另一个单元格值。这可能是通过先读取项目名称进行查找，然后读取要匹配的周数和 return 灰色区域的阶段来解决的，但是对我来说很难同时进行 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.

Answer 1

使用几个 Dictionary Objects 作为对项目行和周列的查找。

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

查找和 return 之间有一个单元格间隙的另一个单元格值

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

excel

vba

multiple-value

match

vlookup