VBA代码，用于比较两个工作表中的两列并复制通用数据

Question

我在一张纸(表 1(中有 100 万条记录，另一张纸(表 2(中有 16k 条记录。根据工作表 2 中每行的前 20 个字符，它应该检查工作表 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

我假设你熟悉vlookup函数，如果是这样，那么你可以使用部分vlookup来完成你的任务。

假设以下情况：

1. 查找值：工作表 2，A 列
2. 查找表：工作表 1，A 到 B 列
3. 返回值：查找表的第 2 列

根据需要调整此公式：(当前设置为在工作表 2 第一行上使用(

=VLOOKUP(LEFT($A 1,20(&"*"，Sheet1！$A：$B，2，FALSE(

Answer 2

这对我来说是一个有用的学习工具，所以我继续创建了 VBA 来回答您最初的问题。正如吉滕德拉·辛格(Jitendra Singh(所提到的，这是蛮力和资源，消耗性。在我的机器上，只做 20 行就花了 ~1000 秒。因此，对于您的 16,000 个条目，它很容易花费 5 分钟以上。考虑到这一点，我设计了几个安全网：

• 用户输入，以确定您一次要查看多少行。我建议小口吃。
• 一个计时器，每 10 秒暂停一次，以确保您要继续前进(调整If tmElapsed > 10 Then行的时间(
• 如果用户选择超过 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

祝你好运。