Encontre valores ao lado da célula mesclada

Question

Eu tenho o seguinte problema:

Eu tenho que executar algumas tarefas várias vezes por ano e os números da semana em que eu tenho que fazer essas tarefas estão ao lado de uma célula mesclada que contém a tarefa. Agora eu gostaria de encontrar esses números de semana pesquisando a tarefa.

Abaixo estão os dados que eu enfrento. Na primeira coluna estão as células mescladas e na terceira coluna os números da semana são postados.

Estou usando correspondência de índice para encontrar os valores, mas só consigo criar um valor e gostaria de encontrar todos eles.

    

Answer 1

Você não solicitou uma solução VBA, mas ela parece ser a mais fácil de implementar. Você também não especificou como queria que seus dados fossem exibidos, nem como você queria poder selecionar a tarefa / semanas a serem exibidas.

Assumi ou escolhi o seguinte, que pode ser alterado:

• As tarefas e as semanas estariam nas colunas A e C, conforme mostrado acima
• A Tarefa relevante será escolhida em uma lista suspensa de células, implementada por meio da validação de dados, e essa lista de tarefas será alfabetizada (classificada)
• Como sua lista de tarefas inclui vírgulas, precisamos criar a lista de tarefas como um intervalo de células em uma planilha. Esta planilha será uma folha oculta.
• A lista será enviada em uma caixa de mensagens
• O algoritmo permite tarefas duplicadas na coluna A
• A lista de semanas retornadas depende criticamente da área mesclada da lista de tarefas. Se você nunca migrar as células, o algoritmo precisará de ajustes.
• A lista será atualizada sempre que você fizer uma alteração na lista de tarefas ou alterar a tarefa selecionada na caixa suspensa.

Código da Planilha

Right-click the Worksheet Tab and select 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

Módulo regular

Select Insert Module from the Menu Bar of the VB Editor

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

Select Insert Module from the Menu Bar of the VB Editor to insert a second regular module. You could put both in the same module, but debugging may be simpler this way

If you do put both macros in the same module, remove the 2nd instance of 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

    

Answer 2

Existe um motivo pelo qual você não pode usar .Next ? Por exemplo, se você selecionar uma das células com uma tarefa, Selection.Next.Next.Text pegará o texto da célula com duas colunas ou Selection.Next.Next.Value obterá o valor dessa célula. (Se você não estiver selecionando diretamente a tarefa, poderá aplicar .Next.Next.Text ou .Next.Next.Value programaticamente.)