Vlookup без повторов с использованием VBA на Excel - PullRequest
0 голосов
/ 22 мая 2019

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

Структура

  1. Обе таблицы должны быть сначала отфильтрованы, чтобы разрешить условие неповторения.
  2. Сохранять искомые значения в виде массивов, чтобы ускорить процесс макроса
  3. Сопоставить записиискать с теми из целевой таблицы, чтобы найти совпадения.Это делается с помощью встроенной функции MATCH.Функция MATCH возвращает ячейку, в которой находится совпадение, это полезно, поскольку она постоянно смещает диапазон, чтобы не повторять одно и то же значение все время.
  4. После вычисления диапазона смещения я использую функцию VLookupчтобы вернуть вторую запись.

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

Желаемый результат

На изображении ниже желаемый результат будет проверять,все элементы в левой таблице находятся в правой таблице.Возьми предмет А, мне нужно найти два предмета как.В правом столбце у меня есть первый элемент A со значением 17 и второй элемент A со значением 81. Если я не нахожу никакого значения, у меня ничего нет, как в случае с Ds и E. Если вместо этого у меня меньше записей влевая таблица (как и в случае записи L), тогда мне нужно вернуть все значения записи L: 96;77;40.

enter image description here

    Sub Matching11()
ThisWorkbook.Activate

Worksheets.add

Worksheets("Test4").Range("A1:T110").copy Destination:=ActiveSheet.Range("A1")

With ActiveSheet

    Dim Search_Array As Variant
    Search_Array = Range("C2", Range("C1").End(xlDown)) 'use this array to loop through the value to search for


    Dim Target_MatchValue As Integer
    Dim Target_Range As Range
    Dim arr As Variant
    Dim counter As Integer
    Dim n As Integer



    counter = 0
    n = 0
    Target_MatchValue = 0

    For counter = LBound(Search_Array) To UBound(Search_Array)
        Target_MatchValue = 0

        Target_MatchValue = Application.Match(Search_Array(counter, 1), .Range("H2:H200"), 0) - 1 'change C column with the range where you will have the tyres you need search for
        Set Target_Range = .Range(.Cells(2 + n, 8), .Cells(1000, 9))  'this is supposed to work as a shifting range allowing to match entries without making repetitions. I used the MATCH function in order to set the start of the range. i.e. if there is a match in the target table the range will shift from the location of the match downwards. If the match is at on the same level then it does not shift the range in order to match the same-level entry afterwards it is supposed to shift by one unit in order to prevent repetitions.
        'If arr = Application.VLookup(Search_Array(counter, 1), Target_Range, 2, False) Is Nothing Then GoTo NextCounter    'I used Vlookup in order to return the value set in the second column of the targetted table. As alternative, I think I could just use offset since I previously used MQTCH


        arr = Application.VLookup(Search_Array(counter, 1), Target_Range, 2, False)
        If IsError(arr) Then
            GoTo NextCounter
            Else
            .Range(Cells(1 + counter, 6), Cells(1 + counter, 6)).value = arr 'Return the value of the array in this cell
        End If
        Target_Range.Select

        If Target_MatchValue = 0 Then

            n = n + 1

            ElseIf Target_MatchValue > 0 Then
            n = n + Target_MatchValue
        End If
        .Range(Cells(1 + counter, 5), Cells(1 + counter, 5)).value = Search_Array(counter, 1) 'Return the value of the array in this cell
    Next counter

NextCounter:
Next counter

End With

End Sub

Ответы [ 2 ]

0 голосов
/ 28 мая 2019

Извините за неясное объяснение проблемы.Ниже я предоставил решение, которое я выбрал.Я искал код, который мог бы выполнить vlookup без возврата тех же значений.Ниже приведено решение.Я знаю, что код может быть не самым чистым и элегантным, но он эффективен и работает достаточно быстро для большой выборки данных.

Sub Matching()

    Dim Search_Array As Variant
    Dim Target_MatchValue As Variant
    Dim Target_Range As Range
    Dim arr As Variant
    Dim counter As Integer
    Dim n As Integer

    'data must be ordered in order to apply the non-repetitive condition
    Search_Array = Sheet1.Range("A2", Sheet1.Range("A1").End(xlDown)) 'use this array to loop through the value to search for


    n = 0
    Sheet1.Activate
    With ActiveSheet
        For counter = LBound(Search_Array) To UBound(Search_Array)

            Target_MatchValue = 0
            Target_MatchValue = Application.Match(Search_Array(counter, 1), .Range(Cells(2 + n, 4), Cells(1000, 4)), 0) 'This code will return the value used for the shifting range
            Set Target_Range = .Range(Cells(2 + n, 4), Cells(1000, 5))  'this is supposed to work as a shifting range allowing to match entries without making repetitions. I used the MATCH function in order to set the start of the range. i.e. if there is a match in the target table the range will shift from the location of the match downwards. If the match is at on the same level then it does not shift the range in order to match the same-level entry afterwards it is supposed to shift by one unit in order to prevent repetitions.
            'target_range.select Activate this code in order to see the macro in action
            arr = Application.VLookup(Search_Array(counter, 1), Target_Range, 2, False) 'store the vlookup value in an array in order to increase the efficiency the code and to speed up the whole proces

                If IsError(arr) Then
                    .Cells(2 + n, 2).value = "" 'if the macro does not find anything, no value will be recorded anywhere

                    Else
                    .Cells(1 + n + Target_MatchValue, 2).value = Search_Array(counter, 2)  'Return the value of the search_array in this cell so to match column A values with column D values if they are found

                End If

                If IsError(arr) Then
                        n = n
                    ElseIf Target_MatchValue = 0 Then 'if the macro does not find anything, the shifting range does not shift so that subsequent values can be searched in the same range without missing precious matches
                        n = n + 1

                    ElseIf Target_MatchValue > 0 Then 'if there is a matching value between Column A and Column B, the shifting range shifts by the n + the distance between the the current vlookupvalue and the found value. Note that Data must be stored in a filtered order otherwise vlookup will not work correctly
                        n = n + Target_MatchValue

                End If
        Next counter

    End With

End Sub

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

enter image description here

Идея в том, что если в столбце E найдено значение, я сохраняю n равным найденному значениюв столбце помощника.Затем код должен проверить, больше ли будущие значения 'n, чем предыдущие n.Если это условие выполняется, то условие с одним повторением выполняется.n изменяет значение на следующее большее значение.Например, если я нахожу L в правой таблице, я сообщаю 96 как значение и сохраняю N равным 11. Когда я ищу следующее значение L, новое n должно быть больше текущего n, иначе я не буду хранитьновое найденное значение.Найденное значение 77 действительно имеет большее n, чем предыдущее значение, так как 12 больше 11. Надеюсь, это поможет.

0 голосов
/ 22 мая 2019

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

Я ответил на ваши данные так:

enter image description here

Макрос создаст список в столбцах H: Мне нравится правая таблица вашего изображения. Макрос всегда удаляет любой предыдущий результат. Мой макрос работает на стандартных диапазонах, не предназначен для работы с таблицами (ListObjects в VBA), но вы можете легко адаптировать его к вашим потребностям.

Sub CREATE_LIST()
Application.ScreenUpdating = False
Dim LastRow As Long
Dim MyRange As Range
Dim rng As Range
Dim i As Long


'we clear previous list
Columns("H:I").Delete

'we add data
Range("H1").Value = "Target"
Range("I1").Value = "Return"

LastRow = Range("C" & Rows.Count).End(xlUp).Row 'Last row of column C, where data is.

Set MyRange = Range("D2:D" & LastRow).SpecialCells(xlCellTypeConstants, 23) 'we select only NON BLANK cells

i = 2 'initial row

For Each rng In MyRange
    Range("H" & i).Value = rng.Offset(0, -1).Value 'value of adjacent cell (Column C)
    Range("I" & i).Value = rng.Value 'value of cell in column D
    i = i + 1
Next rng

Application.ScreenUpdating = True

End Sub

После выполнения кода я получаю: enter image description here

И пробовать разные данные тоже можно: enter image description here

Надеюсь, вы сможете адаптировать это к вашим потребностям.

...