使用唯一标识从工作簿中检索信息

我有两个工作簿，一个是活动列表（数据库），另一个是项目跟踪器（仪表板）。

两个工作簿都有一个项目ID。

我希望工作簿和活动列表应该有一个循环来匹配确切的项目ID。

如果在活动列表中find项目标识，它将从该行中检索信息，并覆盖项目跟踪器中包含该项目标识的现有行。

这是我所做的代码的一个例子，我做了一些相关的事情，但似乎并没有工作：

Sub AAA() 'If Workbooks("Source.xlsm").Sheets("Sheet2").Range("A2").Value = Workbooks("Target.xlsm").Sheets("Sheet1").Range("A2").Value Then 'Workbooks("Source.xlsm").Sheets("Sheet2").Range("B2").Value = Workbooks("Target.xlsm").Sheets("Sheet1").Range("C2").Value Dim a As Long Dim lastrow As Long Dim lastcol As Long Dim source As Worksheet Dim target As Worksheet Set target = Workbooks("Target.xlsm").Sheets("Sheet1") Set source = Workbooks("Source.xlsm").Sheets("Sheet2") lastrow = source.Range("A" & target.Rows.Count).End(xlUp).Row lastcol = target.Cells(2, target.Columns.Count).Column target.Activate For a = 2 To 50 If source.Range("A" & a).Value = target.Range("A" & a).Value Then target.Range("C" & a).Select Range(ActiveCell, ActiveCell.Offset(0)).Copy source.Range("B" & a).PasteSpecial End If Next a End Sub 

Answer 1

你误解了你如何使用Range对象。 这个.Range("A").Value不起作用，你还需要包含一个行号，比如.Range("A1").Value 。

你的逻辑假定这两个列表的顺序完全一样。 使用Range.Find方法可以解决这个问题。

 Sub AAA() Dim source As Worksheet Dim target As Worksheet Dim cell As Range Dim cellFound As Range Set target = Workbooks("Target.xlsm").Sheets("Sheet1") Set source = Workbooks("Source.xlsm").Sheets("Sheet2") For Each cell In target.Range("A2:A50") ' Try to find this value in the source sheet Set cellFound = source.Range("A:A").Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole) If Not cellFound Is Nothing Then ' A matching value was found ' So copy the cell 2 columns across to the cell adjacent to matching value ' Do a "normal" copy & paste cell.Offset(ColumnOffset:=2).Copy cellFound.Offset(ColumnOffset:=1) ' Or do a copy & paste special values 'cell.Offset(ColumnOffset:=2).Copy 'cellFound.Offset(ColumnOffset:=1).PasteSpecial xlPasteValues Else ' The value in this cell does not exist in the source ' Should anything be done? End If Next End Sub 

你是否知道你正在使用不同的工作表source和target ？

Answer 2

 target.Activate For a = 2 To 50 If source.Range("A" & a).Value = target.Range("A" & a).Value Then target.Range("C" & a).EntireRow.Select Selection.Copy source.Range("B" & a).PasteSpecial End If 

下一个

Answer 3

不知道你将要使用的数据量是多less，但是你也可以使用数组来实现你的目标。

 Option Explicit Sub AAA() Dim i As Long, j As Long, k As Integer Dim source As Worksheet, target As Worksheet Dim arrTarget() As Variant, arrSource() As Variant Dim lrowSrc As Long, lcolSrc As Long, lrowTrgt As Long, lcolTrgt As Long Set target = Workbooks("Book4.xlsb").Sheets("Sheet1") Set source = Workbooks("Book3.xlsb").Sheets("Sheet1") lrowSrc = source.Cells(target.Rows.Count, 1).End(xlUp).Row lcolSrc = source.Cells(2, source.Columns.Count).End(xlToLeft).Column lrowTrgt = target.Cells(target.Rows.Count, 1).End(xlUp).Row lcolTrgt = target.Cells(2, target.Columns.Count).End(xlToLeft).Column target.Activate arrTarget = target.Range(Cells(2, 1), Cells(lrowTrgt, lcolSrc)) source.Activate arrSource = source.Range(Cells(2, 1), Cells(lrowSrc, lcolSrc)) target.Activate For i = LBound(arrTarget, 1) To UBound(arrTarget, 1) For j = LBound(arrSource, 1) To UBound(arrSource, 1) If arrTarget(i, 1) = arrSource(j, 1) Then For k = LBound(arrSource, 2) To UBound(arrSource, 2) arrTarget(i, k) = arrSource(j, k) Next k Exit For End If Next j Next i target.Range("A2").Resize(UBound(arrTarget, 1), UBound(arrTarget, 2)).Value = arrTarget End Sub 

在Target workbook处理12,000行数据，在Source workbook 25,000个数据，并且有6000个匹配项，代码需要9.91秒才能运行。