VBA: Как найти диапазон ячеек для значения и вернуть ячейки рядом с местоположением?

Question

Здравствуйте, это мой первый вопрос, поэтому я постараюсь сделать все возможное, чтобы отформатировать его как можно лучше.

Краткое описание без конкретных названий ячеек ниже

Япытается написать макрос, в котором пользователь вводит значение (X), а макрос ищет диапазон ячеек для значения (X), а затем макрос возвращает значения ячеек в 3 пробелах рядом с тем местом, где находится значение (X)) is.

Пара вещей, которые делают невозможным решение этой проблемы, заключаются в том, что пользователь вводит значение в Sheet1, а значение перемещается в Sheet2 по формуле, и я не могу понять, какиспользовать Find, где значения, которые я ищу, еще не определены в макросе.

Другая сложность заключается в том, что диапазон также не может быть строго определен, так как список может быть длиннее или короче, чемэто в настоящее время, и я не могу знать, когда это изменится.Таким образом, диапазон поиска должен начинаться в зависимости от того, какой список введен пользователем, и должен идти до тех пор, пока не попадет в пустое место.

Например: Range. ("C7: D10") не будет работать, потому что пользователь мог ввести новую информацию, которая изменяет рабочий диапазон, как описано ниже.

Ниже приведен скриншот сдальнейшее объяснение

https://i.stack.imgur.com/wlnhg.jpg

Так что на этом снимке экрана ячейки C3 и D3 являются импортированными значениями из Sheet1.

C3 ((Sheet1! B2)

D3 is (= Sheet1! B3)

Идея состоит в том, что макрос запускается и выполняет поиск в столбце A до совпадения с C3.

Затем функция поиска перемещаетсяболее двух ячеек и выполняет поиск вниз до совпадения с D3 или до совпадения с пустым пространством.

Я не знаю, как запросить макрос для поиска на основе импортированного значения, и я не знаюзнаю, как попросить его найти этот странный определенный диапазон, который мне нужен.Идея состоит в том, что кто-то из моих сотрудников мог бы прийти и добавить строку ниже C10 и добавить необходимую информацию, и макрос все равно будет работать и искать в C11, и после этого будет пустое место, чтобы сказать макросу остановиться.

После того, как поиск найдет совпадение для D3, он вернет значения, смежные с совпадением, в соответствующие ячейки вверху, E3, F3 и G3.

Я надеюсь, что этот вопрос задается таким образомчто люди могут понять, я очень устал, поэтому не могу сказать, написал ли я что-то, что имеет смысл.Спасибо за чтение моего поста, вы все лучшие !!

Answer 1

Решение VBA

Я думаю, что решение без VBA здесь идеально, но я оставлю это здесь отдельно на всякий случай.Это должно работать в вашей ситуации, если в ваших таблицах нет пустых значений.

---

    Sub Test()

    Dim ws As Worksheet: Set Worksheet = ThisWorkbook.Sheets("Sheet2")
    Dim iList As Range, iName As Range
    Dim aLR As Long, cLR As Long

    aLR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

    Set iList = ws.Range("A1:A" & aLR).Find(ws.Range("C3"), LookIn:=xlWhole)

    If Not iList Is Nothing Then
        cLR = iList.Offset(0, 2).End(xlDown).Row
        Set iName = ws.Range(ws.Cells(iList.Row, 3), ws.Cells(cLR, 3)).Find(ws.Range("C4"), LookIn:=xlWhole)
            If Not iName Is Nothing Then
                ws.Range("E3:G3").Value = iName.Offset(0, 1).Resize(1, 3).Value
            End If
    End If

    End Sub

Answer 2

Одной из причин усталости является то, что вы пытались убить до того, как приступили к бойне.Приведенное ниже решение заняло час, чтобы подготовиться и 10 минут, чтобы закодировать.Вставьте весь код в стандартный модуль кода и вызовите функцию MatchRow либо из окна Immediate (? MatchRow), либо из собственного кода, как показано ниже в тестовом протоколе.

Option Explicit

Enum Nws                            ' worksheet navigation
    ' 01 Mar 2019
    NwsCriteriaRow = 3
    NwsList = 1                     ' Columns: (1 = A)
    NwsID = 3
    NwsNumber                       ' (undefined: assigns next integer)
End Enum

Function MatchRow() As Long
    ' 01 Mar 2019
    ' return 0 if not found

    Dim Ws As Worksheet
    Dim Rng As Range
    Dim R As Long

    ' The ActiveWorkbook isn't necessarily ThisWorkbook
    Set Ws = ActiveWorkbook.Worksheets("Sheet2")        ' replace tab's name here
    With Ws
        Set Rng = .Range(.Cells(NwsCriteriaRow, NwsList), .Cells(.Rows.Count, NwsList).End(xlUp))
        R = FindRow(.Cells(NwsCriteriaRow, NwsID).Value, Rng, True)

        If R Then                                       ' skip if no match was found
            Set Rng = .Cells(R + 1, NwsID)
            Set Rng = .Range(Rng, Rng.End(xlDown))
            MatchRow = FindRow(.Cells(NwsCriteriaRow, NwsNumber).Value, Rng)
        End If
    End With
End Function

Private Function FindRow(Crit As Variant, _
                         Rng As Range, _
                         Optional ByVal SearchFromTop As Boolean) As Long
    ' 01 Mar 2019
    ' return 0 if not found

    Dim Fun As Range
    Dim StartCell As Long

    With Rng
        If SearchFromTop Then
            StartCell = 1
        Else
            StartCell = .Cells.Count
        End If

        Set Fun = .Find(What:=Crit, _
                       After:=.Cells(StartCell), _
                       LookIn:=xlValues, _
                       LookAt:=xlWhole, _
                       MatchCase:=False)
    End With

    If Not Fun Is Nothing Then FindRow = Fun.Row
End Function

Функция MatchRow возвращает номер строки Sheet2, в которой находится D3, ища только ту часть столбца D, которая принадлежит списку, указанному в C3.Функция возвращает 0, если совпадений не найдено ни в списке, ни в ID.

Вы не указали, что хотите сделать с найденной строкой.Процедура ниже вернет данные из этой строки.Вместо этого вы можете использовать возможность адресации ячеек для записи в них.

Private Sub RetrieveData()

    Dim R As Long

    R = MatchRow
    MsgBox "ID = " & Cells(R, NwsID).Value & vbCr & _
           "Number = " & Cells(R, NwsNumber).Value
End Sub

Будучи предназначенным для тестирования только вышеупомянутого процесса, не определяет рабочий лист и, следовательно, возвращает данные из ActiveSheet, предположительно длябыть Sheet2.

Answer 3

Поиск дважды

Загрузка рабочей книги (Dropbox)

Sub SearchTwice()

    Const cSheet As String = "Sheet2"   ' Source Worksheet Name
    Const cList As String = "C3"        ' List Cell Range Address
    Const cName As String = "D3"        ' Name Cell Range Address
    Const cListCol As String = "A"      ' List Column Letter
    Const cNameCol As String = "C"      ' Name Column Letter
    Const cFirst As Long = 6            ' First Row
    Const cCol As Long = 3              ' Number of Columns

    Dim rng1 As Range       ' Find List Cell Range
                            ' Found Name Cell Range
    Dim rng2 As Range       ' Next List Cell Range
                            ' Name Search Range
    Dim strList As String   ' List
    Dim strName As String   ' Name

    ' In Source Worksheet
    With ThisWorkbook.Worksheets(cSheet)
        ' Write from List Cell Range to List.
        strList = .Range(cList)
        ' Write from Name Cell Range to Name.
        strName = .Range(cName)
        ' Check if Cell Ranges do NOT contain data.
        If strList = "" Or strName = "" Then  ' Inform user.
            MsgBox "Missing List or Name.", vbCritical, "Missing data"
            Exit Sub
        End If
         ' In List Column
        With .Columns(cListCol)
            ' Create a reference to Find List Cell Range (rng1) containing
            ' List (strList).
            Set rng1 = .Find(strList, .Cells(cFirst - 1), xlValues, xlWhole)
            ' Check if List has not been found.
            If rng1 Is Nothing Then   ' Inform user and exit.
                MsgBox "The list '" & strList & "' has not been found", _
                        vbCritical, "List not found"
                Exit Sub
            End If
            ' Create a reference to Next List Cell Range (rng2).
            Set rng2 = .Find("*", .Cells(rng1.Row), xlValues, xlWhole)
        End With
        ' In Name Column
        With .Columns(cNameCol)
            ' Check if the row of Next List Cell Range (rng2) is greater than
            ' the row of List Cell Range (rng1) i.e. if a cell with a value
            ' has been found below List Cell Range (rng1) in List Column.
            If rng2.Row > rng1.Row Then   ' Next List Cell Range FOUND.
                ' Create a reference to Name Search Range (rng2) which spans
                ' from the cell below Find List Cell Range (rng1) to the cell
                ' above the Next List Cell Range (rng2), but in Name Column.
                Set rng2 = .Cells(rng1.Row + 1).Resize(rng2.Row - rng1.Row - 1)
              Else                        ' Next List Cell Range NOT found.
                ' Create a reference to Name Search Range (rng2) which spans
                ' from the cell below Find List Cell Range (rng1) to the bottom
                ' cell, but in Name column.
                Set rng2 = .Cells(rng1.Row + 1).Resize(.Rows.Count - rng1.Row)
            End If
        End With
        ' In Name Search Range (rng2)
        With rng2
            ' Create a reference to Found Name Cell Range (rng1).
            Set rng1 = .Find(strName, .Cells(.Rows.Count), xlValues, xlWhole)
        End With

        ' Check if Name has not been found.
        If rng1 Is Nothing Then   ' Inform user and exit.
            MsgBox "The name '" & strName & "' has not been found", _
                    vbCritical, "Name not found"
            Exit Sub
        End If

        ' Remarks:
        ' Source Range is calculated by moving the Found Name Cell Range (rng1)
        ' one cell to the right and by resizing it by Number of Columns (cCol).
        ' Target Range is calculated by moving the Name Cell Range one cell
        ' to the right and by resizing it by Number of Columns (cCol).

        ' Copy values of Source Range to Target Range.
        .Range(cName).Offset(, 1).Resize(, cCol) _
                = rng1.Offset(, 1).Resize(, cCol).Value

    End With

    ' Inform user of succes of the operation.
    MsgBox "The name '" & strName & "' was successfully found in list '" & _
            strList & "'. The corresponding data has been written to the " _
            & "worksheet.", vbInformation, "Success"

End Sub

Answer 4

Решение не VBA

1. Преобразование двух диапазонов списка в таблицы
2. Измените имя таблицы на (Formulas Tab > Name Manager > Select Table/Change Name).В частности, вы хотите изменить имена на желаемое имя списка.(Table 1 Name = List1 & Table 2 Name = List2)
3. Затем поместите эти формулы внутрь E3, F3, & G3

---

  E3 = VLOOKUP(D3, Indirect(C3), 2, 0) 
  F3 = VLOOKUP(D3, Indirect(C3), 3, 0)
  G3 = VLOOKUP(D3, Indirect(C3), 4, 0)

---

Это будет динамически обновляться по мере увеличения размеров таблицырасширить.Вы также можете добавить столько таблиц, сколько захотите, и это продолжит работать.

При использовании это выглядит примерно так:

Мое последнее предложение будет заключаться во вложении каждой формулы выше вIFERROR()