检查是否存在值，如果是，则将装订行复制到另一个工作表-VBA

更新：我有2个工作表：基地和référence。 礼仪是恒定的，有520排。 我应该比较它可以有2000行的基地。 我应该从我的引用到基地匹配的每一行。 为了能够例如为第1行，从基地，添加它旁边（从第1行的最后一个单元格旁边）匹配的行从référence，如果不匹配，我会有一个空白。

所以，我试图编写一个代码，如果这个值存在于另一个工作表的另一列上，它应该为列的每一个值find：参考。 如果是复制整个引用，并将其粘贴到第一个工作表中的匹配单元格：base。

我有1600行的基地，以配合参考表520行，我有一个共同的专栏，我可以用作一个关键的两个表。

我已经尝试了不同的方法，没有工作：问题是，它不粘贴旁边的单元格，但删除所有的行，并将其replace参考！ 所以我无法确切地知道匹配的那个。 或者我有一个错误信息：select一个单元格粘贴！

这是我的代码：

Sub CopyPaste2() Dim y, lastrow, c, firstAddress, i Set y = Workbooks.Open("Z:\Base_de_données\Base_Para.xlsx") lastrow = y.Sheets("Réf").Range("G" & Rows.Count).End(xlUp).Row For i = 2 To lastrow With y.Worksheets("base").Cells(i, 7) Set c = .Find(y.Worksheets("Réf").Range("B" & i).Value, LookIn:=xlValues) 'this identifies the values in worksheet called R?f If Not c Is Nothing Then firstAddress = c.Address Do 'c.Entirerow.Copy cySheets("Réf").Range("A" & i & ":D" & i).Copy y.Worksheets("base").Range("A" & i).End(xlUp).Offset(1).PasteSpecial _ Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address <> firstAddress End If End With Next i End Sub 

非常感谢您的帮助！ 我添加了一个样本，我应该得到什么样的结果

Answer 1

创build一个值的数组来定位并使用.AutoFilter一次性收集它们。

 Option Explicit Sub CopyPaste2() Dim vals As Variant, y As Workbook Set y = Workbooks.Open("Z:\Base_de_données\Base_Para.xlsx") With y.Worksheets("Réf") vals = Application.Transpose(.Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value) End With With y.Worksheets("base") If .AutoFilterMode Then .AutoFilterMode = False With .Columns("G").Cells .AutoFilter field:=1, Criteria1:=vals, Operator:=xlFilterValues 'check if there is anything to copy With .Resize(.Rows.Count - 1, 4).Offset(1, -6) If CBool(Application.Subtotal(103, .Cells)) Then .Copy Destination:=.Parent.Worksheets("base").Range("A" & .rows.count).End(xlUp).Offset(1, 0) End If End With End With If .AutoFilterMode Then .AutoFilterMode = False End With End Sub