Код VBA для сравнения двух столбцов из двух таблиц и копирования общих данных

Question

У меня есть 1 миллион записей на одном листе (лист 1) и 16 тысяч записей на другом листе (лист 2). На основе первых 20 символов в каждой строке листа 2 следует проверить каждую строку на листе 1 и скопируйте эту строку в отдельный столбец на любом листе. Я записал пример макроса для первой записи, но я хотел бы упомянуть, поскольку диапазон ячеек для всех функциональных возможностей здесь вместо данных, чтобы адресовать его для всего столбца.

Sub test1()
'
' test1 Macro
' test1
'

'
    Sheets("Sheet2").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = _
        "XYZ00026245931CA9B05500045Y80Invalid value in code ID"
    Sheets("Sheet1").Select
    Range("D1").Select
    Cells.Find(What:="XYZ00026245931CA9B05", After:=ActiveCell, LookIn:= _
        xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Range("C1").Select
    ActiveCell.FormulaR1C1 = _
        "XYZ00026245931CA9B05005000000000000004500Y8                     "
    Range("D1").Select
    ActiveSheet.Paste
End Sub

Answer 1

Это был полезный для меня инструмент обучения, поэтому я решил создать VBA, которая отвечает на ваш оригинальный вопрос. Как упоминал Джитендра Сингх, это грубая сила и ресурс, расходный. На моей машине потребовалось ~ 20 секунд, чтобы сделать только 1000 строк. Таким образом, для ваших 16 000 записей это может занять более 5 минут. Имея это в виду, я разработал его с помощью пары сетей безопасности:

• пользовательского ввода, чтобы определить, сколько строк вы собираетесь просматривать одновременно. Я бы рекомендовал брать его небольшими кусочками.
• таймер, который будет останавливаться каждые 10 секунд, чтобы убедиться, что вы хотите продолжать (настройте время в строке If tmElapsed > 10 Then)
• a предупреждение, если пользователь выбирает более 1000 строк (отрегулируйте количество строк для предупреждения в строке If rngCompare.Cells.Count > 1000 Then)

Тем не менее, вот что я придумал:

Sub Compare20char()
' This Sub will look in the cells specified by the user.
' It will compare the first 20 characters of those cells to the first 20 characters in
' the cells in Sheet1, beginning at A2 and continuing to the end of the data in Column A.
' For each match, it will copy the entire cell in Sheet1, Column A to an array.
' After completing its review, it will paste that array to the first empty cell in Column A of Sheet3.

    Dim cell, rngSource, rngCompare, rngTarget As Range
    Dim arrData() As Variant
    Dim i, LastRow As Integer
    Dim tmRef, tmElapsed, tmTotal As Double

    Set rngSource = Sheets("Sheet1").Range("A2:A" & WorksheetFunction.CountA(Sheets("Sheet1").Range("A:A")))
    i = 0

'Get A Cell Address From The User to Get Number Format From
  On Error Resume Next
    Set rngCompare = Application.InputBox( _
      Title:="Select Reference Range", _
      Prompt:="Select the cells in Sheet2 for which you would like to retrieve the data in Sheet 1.", _
      Type:=8)
  On Error GoTo 0

'Test to ensure User Did not cancel and rngCompare is not excessively large
    If rngCompare Is Nothing Then Exit Sub
    If rngCompare.Cells.Count > 1000 Then
        If MsgBox("You have selected " & rngCompare.Cells.Count & " cells. This may take extended time to run. Continue?", _
            vbQuestion + vbYesNo + vbDefaultButton2, "Warning") = vbNo Then GoTo EscapeHatch
    End If

' Begin timer
    tmRef = Timer

' Begin loop to review each cell and fill array
    For Each cell In rngCompare
        If WorksheetFunction.CountIf(rngSource, Left(cell, 20) & "*") = 1 Then
            i = i + 1
            ReDim Preserve arrData(1 To i)
            arrData(i) = cell.Value
            tmElapsed = Timer - tmRef
            If tmElapsed > 10 Then
                If MsgBox("Since the last break:" & vbNewLine & vbNewLine & "Run time: " & Round(tmElapsed, 2) & " seconds" & vbNewLine _
                    & "Records reviewed: " & i & vbNewLine & vbNewLine & "Continue?" & vbNewLine & vbNewLine & _
                    "(If you select ""No"", the spreadsheet will be unchanged.)", vbQuestion + vbYesNo + vbDefaultButton2, _
                    "Extended Run Time") = vbNo Then GoTo EscapeHatch
                tmTotal = tmTotal + tmElapsed
                tmRef = Timer
            End If
        End If
    Next

' Paste array to end of Column A in Sheet3
    With Sheets("Sheet3")
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
    End With
    Set rngTarget = Sheets("Sheet3").Range("A" & LastRow & ":A" & LastRow + i - 1)
    rngTarget = WorksheetFunction.Transpose(arrData)

' Report results
    tmTotal = tmTotal + tmElapsed
    Debug.Print tmTotal
    MsgBox "Run time: " & Round(tmTotal, 2) & " seconds" & vbNewLine & "Records reviewed: " & i & _
        vbNewLine & vbNewLine & "Records pasted to Sheet3."

Exit Sub

EscapeHatch:
    tmTotal = tmTotal + tmElapsed
    MsgBox "Run time: " & Round(tmTotal, 2) & " seconds" & vbNewLine & "Records reviewed: " & i & _
        vbNewLine & vbNewLine & "No changes made."

End Sub

Удачи.

Answer 2

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

Предполагая следующее:

1. Значение поиска: лист 2, столбец A
2. Таблица поиска: лист 1, столбцы от A до B
3. Возвращаемое значение: столбец 2 справочной таблицы

Настройте эту формулу в соответствии со своими потребностями: (в настоящее время настроено для использования на листе 2, первая строка)

= VLOOKUP (LEFT ($ A1,20) & "*", Sheet1! $ A: $ B, 2, FALSE)