☰

查找合并单元格旁边的值

tag-icon • tag-icon microsoft-excel worksheet-function microsoft-excel-2010
查找合并单元格旁边的值

我有以下问题：

我每年需要多次执行某项任务，而执行这些任务的周数位于包含该任务的合并单元格旁边。现在我想通过搜索任务来找到这些周数。

以下是我面临的数据。第一列是合并的单元格，第三列是发布的周数。

在此处输入图片描述

我正在使用索引匹配来查找值，但我只能得出一个值，但我想找到所有值。

答案1

您没有要求 VBA 解决方案，但它似乎是最容易实现的。您也没有指定希望如何输出数据，也没有指定希望如何选择要显示的任务/周数。

我假设或选择了以下内容，所有这些都可以更改：

  • 任务和周数将位于 A 列和 C 列，如上所示
  • 将从单元格下拉列表中选择相关任务，通过数据验证来实现，并且该任务列表将按字母顺序排列（排序）
  • 由于您的任务列表包含逗号，我们需要将任务列表创建为工作表上的单元格范围。此工作表将是隐藏工作表。
  • 该列表将输出到消息框中
  • 该算法允许 A 列中有重复的任务
  • 返回的周列表主要取决于任务列表的合并区域。如果您取消合并单元格，算法将需要调整。
  • 每当您更改任务列表或更改下拉框中选择的任务时，列表都会更新。

工作表代码

右键单击工作表选项卡并选择View Code

Option Explicit
Private Sub Worksheet_Activate()
    Set rInput = Cells(1, 5)
    Application.EnableEvents = False
        ValidationList
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Set rInput = Cells(1, 5)
    If Not Intersect(Target, Columns(1)) Is Nothing Then
        Application.EnableEvents = False
            ValidationList
        Application.EnableEvents = True
    End If
    If Not Intersect(Target, rInput) Is Nothing Then DisplayWeeks
End Sub

常规模块

Insert Module从 VB 编辑器的菜单栏中选择

Option Explicit
Public rInput As Range
Sub ValidationList()
    Dim colTasks As Collection
    Dim vTasks() As Variant
    Dim V1 As Variant, V2 As Variant
    Dim I As Long

'Read the tasks into a variant array
V1 = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))

'Collect the tasks, eliminate the blanks
'Remove Duplicate entries

Set colTasks = New Collection

On Error Resume Next
For Each V2 In V1
    If V2 <> "" Then colTasks.Add V2, CStr(V2)
Next V2
On Error GoTo 0

'Read tasks into array
ReDim vTasks(1 To colTasks.Count)
For I = 1 To UBound(vTasks)
    vTasks(I) = colTasks(I)
Next I

'Since tasks might contain a comma
'  the list must be on a worksheet
'Create the worksheet if not present
'  and hide it
Dim wsTasks As Worksheet
Dim rTasks As Range

On Error Resume Next
    Set wsTasks = Worksheets("Tasks")
    Select Case Err.Number
        Case 9
            Worksheets.Add
            ActiveSheet.Name = "Tasks"
            Set wsTasks = Worksheets("Tasks")
            wsTasks.Visible = xlSheetHidden
        Case Is <> 0
            Debug.Print Err.Number, Err.Description
            Stop 'for debugging
            Exit Sub
    End Select
On Error GoTo 0

Set rTasks = wsTasks.Cells(1, 1).Resize(1, UBound(vTasks))
rTasks = vTasks

'Sort the task list
rTasks.Sort key1:=rTasks.Rows(1), _
            order1:=xlAscending, _
            Header:=xlNo, _
            MatchCase:=False, _
            Orientation:=xlSortRows

'Create the Input Cell
With rInput
    .Clear
    With .Validation
        .Add Type:=xlValidateList, _
         AlertStyle:=xlValidAlertInformation, _
         Formula1:="=" & rTasks.Worksheet.Name & "!" & rTasks.Address(True, True)
        .InCellDropdown = True
        .InputMessage = "Select from Drop Down List"
        .ShowInput = True
        .ShowError = True
    End With
    
    .Style = "Input"
End With
            
End Sub

从 VB 编辑器的菜单栏中选择Insert Module插入第二个常规模块。您可以将两者放在同一个模块中，但这样调试可能更简单

如果你确实将两个宏放在同一个模块中，请删除第二个实例Option Explicit

Option Explicit

Sub DisplayWeeks()
    Dim colWeeks As Collection
    Dim R1 As Range, R2 As Range, C As Range
    Dim FirstAddress As String
    Dim V As Variant, I As Long

Set colWeeks = New Collection

'Find the task(s)
If rInput = "" Then Exit Sub
With Columns(1)
    Set R1 = .Find(what:=rInput, _
        after:=.Cells(.Rows.Count), _
        LookIn:=xlValues, _
        lookat:=xlWhole, _
        searchorder:=xlByRows, _
        searchdirection:=xlNext, _
        MatchCase:=False)
    If R1 Is Nothing Then
        MsgBox "Something Wrong" & vbLf & """Find"" &  did not work"
        Stop
        Exit Sub
    End If
    
    FirstAddress = R1.Address
    Set R2 = R1.Offset(0, 2).Resize(rowsize:=R1.MergeArea.Rows.Count)
    For Each C In R2
        If C.Text <> "" Then colWeeks.Add C.Text
    Next C
    
    Do
        Set R1 = .FindNext(R1)
            If R1 Is Nothing Then Exit Do
        If R1.Address <> FirstAddress Then
            Set R2 = R1.Offset(0, 2).Resize(rowsize:=R1.MergeArea.Rows.Count)
            For Each C In R2
                If C.Text <> "" Then colWeeks.Add C.Text
            Next C
        End If
    Loop Until R1.Address = FirstAddress
End With

ReDim V(1 To colWeeks.Count)
For I = 1 To UBound(V)
    V(I) = CStr(colWeeks(I))
Next I

Application.Cursor = xlDefault
MsgBox "Weeks for this task:" & vbLf & Join(V, vbLf)

End Sub

答案2

有什么原因导致您无法使用.Next？例如，如果您选择其中一个包含任务的单元格，Selection.Next.Next.Text将会抓取两列外的单元格的文本，或者Selection.Next.Next.Value将会抓取该单元格的值。（如果您没有直接选择任务，您可以以编程方式应用.Next.Next.Text或.Next.Next.Value。）

相关内容