Проверьте столбец и скопируйте, если он совпадает

Question

У меня есть числа в диапазоне G2: G10, я должен проверить, находятся ли эти числа в одной из ячеек в строке B второго файла. Теперь у меня просто есть аргумент true, если в G2 (Файл 1) и B2 (Файл 2) одинаковое число. Но как я могу это сделать, чтобы когда G2 (Файл 1) и B4 (Файл 2) были одинаковыми, if также работал?

    Dim cell As Range
    Dim wb1 As Workbook, ws1 As Worksheet
    Dim wb2 As Workbook, ws2 As Worksheet

    Set wb1 = Application.Workbooks.Open("T:\folder\Map2.xlsm")
    Set ws1 = wb1.Sheets("Tabelle1")
    Set wb2 = Application.Workbooks.Open("T:\folder\file.xlsx")
    Set ws2 = wb2.Sheets("sheet1")



    For Each cell In wb1.Sheets(1).Range("G2:G10")
        If cell.Value = ws2.Cells(cell.Row, "B").Value Then

            ws2.Cells(cell.Row, "D").Resize(1, 3).Select

        End If
    Next cell

End Sub

Answer 1

Попробуйте это

Sub test()
    Dim c As Range, cx As Range, str$
    Dim wb1 As Workbook, ws1 As Worksheet
    Dim wb2 As Workbook, ws2 As Worksheet

    Set wb1 = Application.Workbooks.Open("T:\folder\Map2.xlsm")
    Set ws1 = wb1.Sheets("Tabelle1")
    Set wb2 = Application.Workbooks.Open("T:\folder\file.xlsx")
    Set ws2 = wb2.Sheets("sheet1")

    For Each c In ws1.Range(ws1.Cells(1, 7), ws1.Cells(ws1.Rows.Count, 7).End(xlUp))
        For Each cx In ws2.Range(ws2.Cells(1, 2), ws2.Cells(ws2.Rows.Count, 2).End(xlUp))
            If c = cx Then
                cx.Offset(, 2).Resize(1, 3).Select
                str = str & ", " & cx.Address
                'Msgbox cx.Address
            End If
        Next cx
    Next c
    Msgbox "The following cells meet the conditions: " & Replace(str, ",", "", 1, 1)
End Sub

Answer 2

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

Sub compare()
    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet

    Dim cell As Range
    Dim lastrow As Long

    Dim dict As Object

    Set wb1 = Application.Workbooks.Open("T:\folder\Map2.xlsm")
    Set ws1 = wb1.Sheets("Tabelle1")
    Set wb2 = Application.Workbooks.Open("T:\folder\file.xlsx")
    Set ws2 = wb2.Sheets("sheet1")

    Set dict = CreateObject("Scripting.Dictionary") 'This is late bound you can change to early binding if you want
    With ws2
        lastrow = .Cells(.Rows.Count, 2).End(xlUp).Row

        For Each cell In .Range("B1:B" & lastrow)
            If Not dict.exists(cell.Value) Then 'Avoid errors
                dict.Add cell.Value,cell 'Add key value, item will be the range
            End If
        Next cell
    End With

    With ws1
        For Each cell In Range("G2:G10")
            If dict.exists(cell.Value) Then 'Duplicate found when true
            'Here we take the matched range offset and place it in the new offset range
                Range(cell.Offset(0, 2), cell.Offset(0, 4)).Value = Range(dict(cell.Value).Offset(0, 2), dict(cell.Value).Offset(0, 4)).Value
            End If
        Next cell
    End With


End Sub