Excel VBA для сопоставления нескольких столбцов и получения значения

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

Цель состоит в том, чтобы скопировать совпадающие значения из исходной таблицы (SE) в каждую строку целевой таблицы (FB), используя совпадение во вспомогательной таблице (SA).

На этом рисунке показано, чего я хочу достичь: Таблицы.jpg

Обратите внимание, что в столбце «C» в таблице «SA» нет уникальных значений ключа.

Мой код пока выглядит следующим образом:

Sub MatchTables()


    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim i As Long, j As Long
    Dim newSheetPos As Integer

    Set ws1 = ActiveWorkbook.Sheets("FB") 'Range: last row
    Set ws2 = ActiveWorkbook.Sheets("SA") 'Range: rows 5 to 84
    Set ws3 = ActiveWorkbook.Sheets("SE") 'Range: last row

    For i = 2 To ws1.Cells(ws1.Rows.Count, 3).End(xlUp).Row
        For j = 5 To 84

            If ws1.Cells(i, 3).Value = ws2.Cells(j, 3).Value Then

                If ws2.Cells(i, 3).Value = ws3.Cells(j, 5).Value Then
                    ws3.Cells(j, 6).Copy ws1.Cells(i , 16)
                Else
                End If
            Else
            End If

        Next j
    Next i
End Sub

Большое спасибо за вашу помощь.

Преобразование HTML-таблицы в профессиональный документ Excel
Преобразование HTML-таблицы в профессиональный документ Excel
Это самый простой способ создания Excel из HTML-таблицы.
Импорт excel в laravel в базу данных
Импорт excel в laravel в базу данных
Здравствуйте, дорогой читатель, в этой статье я расскажу практическим и быстрым способом, как импортировать файл Excel в вашу базу данных с помощью...
2
0
33
1
Перейти к ответу Данный вопрос помечен как решенный

Ответы 1

Ответ принят как подходящий

(Супер) двойной поиск

  • Для упрощения предполагается, что каждый из столбцов поиска содержит как минимум 2 строки данных и не содержит ошибочных значений или пробелов.
Sub SuperLookup()

    Const sName As String = "SE"
    Const sfRow As Long = 2
    Const slCol As String = "E" ' 4.) ... here and return...
    Const svCol As String = "F" ' 5.) ... this...
    
    Const lName As String = "SA"
    Const lRowsAddress As String = "5:84"
    Const llCol As String = "C" ' 2.) ... here and return...
    Const lvCol As String = "Q" ' 3.) ... this to look it up...
    
    Const dName As String = "FB"
    Const dfRow As Long = 2
    Const dlCol As String = "C" ' 1.) Look up this...
    Const dvCol As String = "P" ' 6.) ... here.
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, slCol).End(xlUp).Row
    Dim srg As Range
    Set srg = sws.Cells(sfRow, slCol).Resize(slRow - sfRow + 1)
    Dim sData As Variant: sData = srg.EntireRow.Columns(svCol).Value
    
    Dim lws As Worksheet: Set lws = wb.Worksheets(lName)
    Dim lrg As Range: Set lrg = lws.Rows(lRowsAddress).Columns(llCol)
    Dim lData As Variant: lData = lrg.EntireRow.Columns(lvCol).Value
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, dlCol).End(xlUp).Row
    Dim drCount As Long: drCount = dlRow - dfRow + 1
    Dim drg As Range: Set drg = dws.Cells(dfRow, dlCol).Resize(drCount)
    Dim dlData As Variant: dlData = drg.Value
    Set drg = drg.EntireRow.Columns(dvCol)
    Dim dvData As Variant: ReDim dvData(1 To drg.Rows.Count, 1 To 1)
    
    Dim sIndex As Variant
    Dim lIndex As Variant
    Dim lValue As Variant
    Dim dValue As Variant
    Dim dr As Long
    
    For dr = 1 To drCount
        dValue = dlData(dr, 1)
        lIndex = Application.Match(dValue, lrg, 0)
        If IsNumeric(lIndex) Then
            lValue = lData(lIndex, 1)
            sIndex = Application.Match(lValue, srg, 0)
            If IsNumeric(sIndex) Then
                dvData(dr, 1) = sData(sIndex, 1)
            'Else ' not found in source; do nothing
            End If
        'Else ' not found in lookup; do nothing
        End If
    Next dr

    drg.Value = dvData
    
    MsgBox "Super lookup has finished.", vbInformation

End Sub

Другие вопросы по теме